Released DG*5.3*732 SEQ #655 Extracted from mail message **KIDS**:DG*5.3*732^ **INSTALL NAME** DG*5.3*732 "BLD",6977,0) DG*5.3*732^REGISTRATION^0^3061024^y "BLD",6977,1,0) ^^1^1^3061024^ "BLD",6977,1,1,0) POW STATUS NOT TRANSFERRING TO VETERAN'S ID CARD "BLD",6977,4,0) ^9.64PA^^ "BLD",6977,6.3) 2 "BLD",6977,"ABPKG") n "BLD",6977,"KRN",0) ^9.67PA^8989.52^19 "BLD",6977,"KRN",.4,0) .4 "BLD",6977,"KRN",.401,0) .401 "BLD",6977,"KRN",.402,0) .402 "BLD",6977,"KRN",.403,0) .403 "BLD",6977,"KRN",.5,0) .5 "BLD",6977,"KRN",.84,0) .84 "BLD",6977,"KRN",3.6,0) 3.6 "BLD",6977,"KRN",3.8,0) 3.8 "BLD",6977,"KRN",9.2,0) 9.2 "BLD",6977,"KRN",9.8,0) 9.8 "BLD",6977,"KRN",9.8,"NM",0) ^9.68A^2^2 "BLD",6977,"KRN",9.8,"NM",1,0) DGOINPT1^^0^B25992008 "BLD",6977,"KRN",9.8,"NM",2,0) DGQEUT1^^0^B32594706 "BLD",6977,"KRN",9.8,"NM","B","DGOINPT1",1) "BLD",6977,"KRN",9.8,"NM","B","DGQEUT1",2) "BLD",6977,"KRN",19,0) 19 "BLD",6977,"KRN",19.1,0) 19.1 "BLD",6977,"KRN",101,0) 101 "BLD",6977,"KRN",409.61,0) 409.61 "BLD",6977,"KRN",771,0) 771 "BLD",6977,"KRN",870,0) 870 "BLD",6977,"KRN",8989.51,0) 8989.51 "BLD",6977,"KRN",8989.52,0) 8989.52 "BLD",6977,"KRN",8994,0) 8994 "BLD",6977,"KRN","B",.4,.4) "BLD",6977,"KRN","B",.401,.401) "BLD",6977,"KRN","B",.402,.402) "BLD",6977,"KRN","B",.403,.403) "BLD",6977,"KRN","B",.5,.5) "BLD",6977,"KRN","B",.84,.84) "BLD",6977,"KRN","B",3.6,3.6) "BLD",6977,"KRN","B",3.8,3.8) "BLD",6977,"KRN","B",9.2,9.2) "BLD",6977,"KRN","B",9.8,9.8) "BLD",6977,"KRN","B",19,19) "BLD",6977,"KRN","B",19.1,19.1) "BLD",6977,"KRN","B",101,101) "BLD",6977,"KRN","B",409.61,409.61) "BLD",6977,"KRN","B",771,771) "BLD",6977,"KRN","B",870,870) "BLD",6977,"KRN","B",8989.51,8989.51) "BLD",6977,"KRN","B",8989.52,8989.52) "BLD",6977,"KRN","B",8994,8994) "BLD",6977,"QUES",0) ^9.62^^ "BLD",6977,"REQB",0) ^9.611^2^2 "BLD",6977,"REQB",1,0) DG*5.3*544^2 "BLD",6977,"REQB",2,0) DG*5.3*679^2 "BLD",6977,"REQB","B","DG*5.3*544",1) "BLD",6977,"REQB","B","DG*5.3*679",2) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,20,0) ^9.402P^^ "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 732^3061024 "PKG",5,22,1,"PAH",1,1,0) ^^1^1^3061024 "PKG",5,22,1,"PAH",1,1,1,0) POW STATUS NOT TRANSFERRING TO VETERAN'S ID CARD "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 2 "RTN","DGOINPT1") 0^1^B25992008^B24737842 "RTN","DGOINPT1",1,0) DGOINPT1 ;ALB/REW - BUILDS,PRINTS INPATIENT ROSTER ; 8/8/03 11:45am "RTN","DGOINPT1",2,0) ;;5.3;Registration;**162,498,544,732**;Aug 13, 1993;Build 2 "RTN","DGOINPT1",3,0) ; "RTN","DGOINPT1",4,0) ; "RTN","DGOINPT1",5,0) ; DGS1 IS USED FOR SORTING PRINT "RTN","DGOINPT1",6,0) ; DGS2 IS USED FOR X-REF LOOKUP "RTN","DGOINPT1",7,0) ROSTER ; "RTN","DGOINPT1",8,0) S X=132 X ^%ZOSF("RM") "RTN","DGOINPT1",9,0) D NOW^%DTC S Y=$E(%,1,12),DGADMT=$$FMTE^XLFDT(Y,1) "RTN","DGOINPT1",10,0) S TOT=0,DGS="",DGS1="" "RTN","DGOINPT1",11,0) I DGHOW="W" S DGXREF="CN" D ROST "RTN","DGOINPT1",12,0) I DGHOW="P","EP"[DGPVAR S DGXREF="APR" D ROST "RTN","DGOINPT1",13,0) I DGHOW="P","EA"[DGPVAR S DGXREF="AAP" D ROST "RTN","DGOINPT1",14,0) I DGHOW="P",DGPVAR="E" D FIXTOT "RTN","DGOINPT1",15,0) D DOLIST "RTN","DGOINPT1",16,0) QUIT W ! "RTN","DGOINPT1",17,0) K ^TMP($J),DGLIST,DGS,ROOMB,CPS,DFN,DGADMT,DGADM,DGCPYS,DGDAYS,DGDS,DGDV,DGI,DGJ,DGPGM,DGPMDD("DA"),DGVAR,DGWD,DGX,I,J,K,NM,TOT,VAUTD,VAUTW,WD,X,Y "RTN","DGOINPT1",18,0) K DGHOW,DGPVAR,DGS1,DGSUBS,DGTM,DGUTV,DIC,X1,XMDT,XMM,DGXREF,ZZ,DGPMIFN,DGS2,VADAT,VADATE,VADM,VAEL,VAIN,Z,DGTMPV,DGFL,DIR,DGBID "RTN","DGOINPT1",19,0) D KVAR^VADPT,KVAR^VADATE,CLOSE^DGUTQ,ENDREP^DGUTL "RTN","DGOINPT1",20,0) Q "RTN","DGOINPT1",21,0) FIXTOT ; "RTN","DGOINPT1",22,0) S DGS="" "RTN","DGOINPT1",23,0) F DGI=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D "RTN","DGOINPT1",24,0) .S DGUTV="^TMP("_$J_","""_DGS_""")" "RTN","DGOINPT1",25,0) .F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) "RTN","DGOINPT1",26,0) .S ^TMP($J,"DGLIST",DGS)=ZZ "RTN","DGOINPT1",27,0) Q "RTN","DGOINPT1",28,0) ROST ; "RTN","DGOINPT1",29,0) F DGI=0:0 S:DGS]""&TOT ^TMP($J,"DGLIST",DGS1)=TOT S TOT=0,DGS=$S((VAUTW):$O(^DPT(DGXREF,DGS)),1:$O(VAUTW(DGS))) Q:DGS="" D CHECK I DGFL S DFN="" F DGJ=0:0 S DFN=$O(^DPT(DGXREF,DGS2,DFN)) Q:DFN="" D ADMDT "RTN","DGOINPT1",30,0) Q "RTN","DGOINPT1",31,0) ADMDT ; "RTN","DGOINPT1",32,0) N DGVAIN7,VAL "RTN","DGOINPT1",33,0) D QKVADPT Q:'VAIN(7) S DGBID=VA("BID") S TOT=TOT+1,X=+VAIN(7),DGVAIN7="" I X S X=$$FMTE^XLFDT(X,"5DF"),X=$TR(X," ","0"),X=$TR(X,"/","-"),DGVAIN7=X "RTN","DGOINPT1",34,0) S DGPMIFN=VAIN(1) D ^DGPMLOS S DGDAYS=$P(X,"^",5) "RTN","DGOINPT1",35,0) S VAL=VADM(1)_U_DGBID_U_VADM(4)_U_DGVAIN7_U_DGDAYS_U_VAIN(4)_U_VAIN(5)_U_$P(VAIN(2),U,2) "RTN","DGOINPT1",36,0) S VAL=VAL_U_$P(VAIN(11),U,2)_U_$P(VAIN(3),U,2)_U_$P(VAEL(9),U,1)_U_$P(VAIP(19,1),U,1) "RTN","DGOINPT1",37,0) S ^TMP($J,DGS1,$S(DGSUBS="R":+$$RM(VAIN(5)),1:VADM(1)),+DGBID)=VAL "RTN","DGOINPT1",38,0) Q "RTN","DGOINPT1",39,0) CHECK ; "RTN","DGOINPT1",40,0) S DGFL=1 "RTN","DGOINPT1",41,0) I DGHOW="P",VAUTW S DGS1=$S($D(^VA(200,DGS,0)):$P($G(^VA(200,DGS,0)),U,1),1:DGS),DGS2=DGS Q "RTN","DGOINPT1",42,0) I DGHOW="P",'VAUTW S DGS1=DGS,DGS2=VAUTW(DGS) Q "RTN","DGOINPT1",43,0) S DGWD=$O(^DIC(42,"B",DGS,0)) I DGWD S DGDV=$S('$D(^DIC(42,DGWD,0)):0,+$P(^(0),"^",11):$P(^(0),"^",11),1:$O(^DG(40.8,0))) "RTN","DGOINPT1",44,0) I 'VAUTD,'$D(VAUTD(DGDV)) S DGFL=0 "RTN","DGOINPT1",45,0) S (DGS1,DGS2)=DGS "RTN","DGOINPT1",46,0) Q "RTN","DGOINPT1",47,0) WAIT I $E(IOST)="C" S DIR(0)="E" D ^DIR S:'Y DGX=1 "RTN","DGOINPT1",48,0) Q "RTN","DGOINPT1",49,0) DOLIST ; "RTN","DGOINPT1",50,0) S DGX=0 "RTN","DGOINPT1",51,0) F CPS=1:1:DGCPYS S DGS="" F I=0:0 S DGS=$O(^TMP($J,"DGLIST",DGS)) Q:DGS="" D HEAD,OUT G QTDOL:DGX D WAIT G QTDOL:DGX "RTN","DGOINPT1",52,0) QTDOL Q "RTN","DGOINPT1",53,0) HEAD S X=$S(DGHOW="W":"WARD",DGPVAR="E":"PROVIDER",DGPVAR="P":"PRIMARY PHYSICIAN",1:"ATTENDING PHYSICIAN")_": "_DGS_" "_^TMP($J,"DGLIST",DGS)_" PATIENTS" "RTN","DGOINPT1",54,0) W:IOF]"" @IOF W !!?4,"INPATIENT ROSTER",?(61-($L(X)/2)),X,?99 W DGADMT "RTN","DGOINPT1",55,0) W !!?33,"ADMISSION",?78,"PRIMARY",?95,"ATTENDING",?112,"TREATING",?126,"MEANS" "RTN","DGOINPT1",56,0) W !,"PATIENT NAME",?21,"ID",?28,"AGE",?33,"DATE",?46,"DAYS",?52,"WARD",?67,"ROOM-BED",?78,"PHYSICIAN",?95,"PHYSICIAN",?112,"SPECIALTY",?126,"TEST" K X S $P(X,"-",133)="" W !,X,! Q "RTN","DGOINPT1",57,0) OUT ; "RTN","DGOINPT1",58,0) S DGUTV="^TMP("_$J_","""_DGS_""")" "RTN","DGOINPT1",59,0) F ZZ=0:1 S DGUTV=$Q(@DGUTV) Q:DGUTV=""!($TR(DGUTV,"""")'[($J_","_DGS_",")) S DGADM=@DGUTV D PRINT I $Y>(IOSL-6),($TR($Q(@DGUTV),"""")[($J_","_DGS_",")) D LEGEND,WAIT G QTOUT:DGX D HEAD "RTN","DGOINPT1",60,0) I $Y<(IOSL-5) D LEGEND "RTN","DGOINPT1",61,0) QTOUT Q "RTN","DGOINPT1",62,0) PRINT ; "RTN","DGOINPT1",63,0) W !,$S($P(DGADM,U,12):"!",1:""),$E($P(DGADM,U,1),1,19),?21,$P(DGADM,U,2),?28,$J($P(DGADM,U,3),3) "RTN","DGOINPT1",64,0) W ?33,$P(DGADM,U,4),?46,$J($P(DGADM,U,5),4),?52,$E($P(DGADM,U,6),1,14),?67,$E($P(DGADM,U,7),1,9),?78,$E($P(DGADM,U,8),1,15) "RTN","DGOINPT1",65,0) W ?95,$E($P(DGADM,U,9),1,15),?112,$E($P(DGADM,U,10),1,13),?128,$P(DGADM,U,11) W:DGDS ! "RTN","DGOINPT1",66,0) Q "RTN","DGOINPT1",67,0) RM(ROOMB) ; "RTN","DGOINPT1",68,0) ;IGNORES CHARACTERS BEFORE THE FIRST NON-ZERO NUMBER "RTN","DGOINPT1",69,0) ;RETURNS NUMBERS IN ROOM-BED BEFORE THE FIRST '-' OR '/' THE REMAINING "RTN","DGOINPT1",70,0) ;NUMBERS ARE DIVIDED BY 100,000 AND ADDED TO THE FIRST PART "RTN","DGOINPT1",71,0) ; E.G. 'A-12E-A103C' "RTN","DGOINPT1",72,0) ;WILL RETURN: 12.000103 "RTN","DGOINPT1",73,0) ; "RTN","DGOINPT1",74,0) NEW ROOM1,BEG "RTN","DGOINPT1",75,0) S ROOM1=$TR(ROOMB,"123456789","111111111") "RTN","DGOINPT1",76,0) S BEG=$F(ROOM1,1)-1 "RTN","DGOINPT1",77,0) S ROOMB=$TR($E(ROOMB,BEG,99),"-/ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ~!@#$%^&*()_+=`|\{}[]:"";'<>?,.","..") "RTN","DGOINPT1",78,0) S:$L(ROOMB,".")>1 ROOMB=$P(ROOMB,".",1)+(($TR(($P(ROOMB,".",2,99)),"."))/1000000) "RTN","DGOINPT1",79,0) Q +ROOMB "RTN","DGOINPT1",80,0) QKVADPT ;QUICK SUBSTITUTE FOR VADPT:REQUIRES DFN "RTN","DGOINPT1",81,0) NEW K,I,DGX "RTN","DGOINPT1",82,0) S K=0 "RTN","DGOINPT1",83,0) F I=.105,.104,.103,.1,.101 S K=K+1,VAIN(K)=$G(^DPT(DFN,I)) "RTN","DGOINPT1",84,0) S VAIN(11)=$G(^DPT(DFN,.1041)) "RTN","DGOINPT1",85,0) S VAIN(7)=+$G(^DGPM(+VAIN(1),0)) "RTN","DGOINPT1",86,0) F I=2,11 S:$D(^VA(200,+VAIN(I),0)) VAIN(I)=VAIN(I)_U_$P(^(0),U,1) "RTN","DGOINPT1",87,0) S:$D(^DIC(45.7,+VAIN(3),0)) VAIN(3)=VAIN(3)_U_$P(^(0),U,1) "RTN","DGOINPT1",88,0) ;code added to differentiate ambiguous treating speialty names. "RTN","DGOINPT1",89,0) S:($E($P(VAIN(3),U,2),1,7)="NH LONG")!($E($P(VAIN(3),U,2),1,8)="NH SHORT") VAIN(3)=$P(^(0),U,2)_U_$P($G(^DIC(42.4,+$P(^(0),U,2),0)),U,2) "RTN","DGOINPT1",90,0) DEM S VADM(1)=$P($G(^DPT(DFN,0)),U,1) "RTN","DGOINPT1",91,0) S VAIP(19,1)=$P($G(^DGPM(+VAIN(1),"DIR")),"^",1) "RTN","DGOINPT1",92,0) S:VAIP(19,1)="" VAIP(19,1)=1 "RTN","DGOINPT1",93,0) S DGX=$P($G(^DPT(DFN,0)),U,3) "RTN","DGOINPT1",94,0) S VADM(4)=$E(DT,1,3)-$E(DGX,1,3)-($E(DT,4,7)<$E(DGX,4,7)) "RTN","DGOINPT1",95,0) D PID^VADPT6 "RTN","DGOINPT1",96,0) MT S VAEL(9)=$P($$MTS^DGMTU(DFN),U,2) "RTN","DGOINPT1",97,0) Q "RTN","DGOINPT1",98,0) LEGEND F Q:($Y>(IOSL-5)) W ! "RTN","DGOINPT1",99,0) W !,"'!' Before the Patient name indicates the patient chose not to be listed in the Facility Directory" "RTN","DGOINPT1",100,0) Q "RTN","DGQEUT1") 0^2^B32594706^B31813061 "RTN","DGQEUT1",1,0) DGQEUT1 ;ALB/RPM - VIC REPLACEMENT UTILITIES #1 ; 10/03/05 "RTN","DGQEUT1",2,0) ;;5.3;Registration;**571,679,732**;Aug 13, 1993;Build 2 "RTN","DGQEUT1",3,0) ; "RTN","DGQEUT1",4,0) ; This routine contains the following VIC Redesign API's: "RTN","DGQEUT1",5,0) ; INITARR - initialize data array "RTN","DGQEUT1",6,0) ; $$GETPAT - build Patient data array "RTN","DGQEUT1",7,0) ; $$GETELIG - build Patient Eligibility data array "RTN","DGQEUT1",8,0) ; $$GETPH - determine Purple Heart status "RTN","DGQEUT1",9,0) ; $$GETPOW - determine Prisoner of War status "RTN","DGQEUT1",10,0) ; $$FNDPOW - search for Prisoner of War eligibility code "RTN","DGQEUT1",11,0) ; $$ISENRPND - is enrollment status pending "RTN","DGQEUT1",12,0) ; "RTN","DGQEUT1",13,0) Q ;no direct entry "RTN","DGQEUT1",14,0) ; "RTN","DGQEUT1",15,0) INITARR(DGVIC) ;Procedure used to initialize VIC data array nodes. "RTN","DGQEUT1",16,0) ; "RTN","DGQEUT1",17,0) ; Input: "RTN","DGQEUT1",18,0) ; none "RTN","DGQEUT1",19,0) ; "RTN","DGQEUT1",20,0) ; Output: "RTN","DGQEUT1",21,0) ; DGVIC - array of VIC data (pass by reference) "RTN","DGQEUT1",22,0) ; "RTN","DGQEUT1",23,0) N DGSUB ;array subscript "RTN","DGQEUT1",24,0) ; "RTN","DGQEUT1",25,0) ;init patient identifier nodes "RTN","DGQEUT1",26,0) S DGVIC("DFN")="" "RTN","DGQEUT1",27,0) F DGSUB="NAME","SSN","DOB","LAST","FIRST","MIDDLE","SUFFIX","PREFIX" D "RTN","DGQEUT1",28,0) . S DGVIC(DGSUB)="" "RTN","DGQEUT1",29,0) ; "RTN","DGQEUT1",30,0) ;init address nodes "RTN","DGQEUT1",31,0) F DGSUB="STREET1","STREET2","STREET3","CITY","STATE","ZIP","ADRTYPE" D "RTN","DGQEUT1",32,0) . S DGVIC(DGSUB)="" "RTN","DGQEUT1",33,0) ; "RTN","DGQEUT1",34,0) ;init vic eligibility nodes "RTN","DGQEUT1",35,0) F DGSUB="SC","ENRSTAT","ELIGSTAT","MST","COMBVET","POW","PH" D "RTN","DGQEUT1",36,0) . S DGVIC(DGSUB)="" "RTN","DGQEUT1",37,0) ; "RTN","DGQEUT1",38,0) ;init facility nodes "RTN","DGQEUT1",39,0) F DGSUB="FACNUM","FACNAME","VISN" D "RTN","DGQEUT1",40,0) . S DGVIC(DGSUB)="" "RTN","DGQEUT1",41,0) ; "RTN","DGQEUT1",42,0) ;init card print release status node "RTN","DGQEUT1",43,0) S DGVIC("STAT")="" "RTN","DGQEUT1",44,0) ; "RTN","DGQEUT1",45,0) ;init document type node "RTN","DGQEUT1",46,0) S DGVIC("DOCTYPE")="VIC" "RTN","DGQEUT1",47,0) ; "RTN","DGQEUT1",48,0) Q "RTN","DGQEUT1",49,0) ; "RTN","DGQEUT1",50,0) ; "RTN","DGQEUT1",51,0) GETPAT(DGDFN,DGPAT) ;build Patient object "RTN","DGQEUT1",52,0) ; This function retrieves patient demographic data needed to produce "RTN","DGQEUT1",53,0) ; a Veteran ID Card and returns the data in an array format. "RTN","DGQEUT1",54,0) ; "RTN","DGQEUT1",55,0) ; Supported Reference: "RTN","DGQEUT1",56,0) ; DBIA #10103: $$FMTE^XLFDT "RTN","DGQEUT1",57,0) ; "RTN","DGQEUT1",58,0) ; Input: "RTN","DGQEUT1",59,0) ; DGDFN - (required) pointer to patient in PATIENT (#2) file "RTN","DGQEUT1",60,0) ; "RTN","DGQEUT1",61,0) ; Output: "RTN","DGQEUT1",62,0) ; Function value - returns 1 on success, 0 on failure "RTN","DGQEUT1",63,0) ; DGPAT - array of patient demographics, pass by reference "RTN","DGQEUT1",64,0) ; Array subscripts are: "RTN","DGQEUT1",65,0) ; "DFN" - Pointer to patient in PATIENT (#2) file "RTN","DGQEUT1",66,0) ; "NAME" - Patient Full Name "RTN","DGQEUT1",67,0) ; "SSN" - Social Security Number "RTN","DGQEUT1",68,0) ; "DOB" - Date of Birth (mmddyyyy) "RTN","DGQEUT1",69,0) ; "LAST" - Family Name from name components "RTN","DGQEUT1",70,0) ; "FIRST" - Given Name from name components "RTN","DGQEUT1",71,0) ; "MIDDLE" - Middle Name from name components "RTN","DGQEUT1",72,0) ; "SUFFIX" - Suffix from name components "RTN","DGQEUT1",73,0) ; "PREFIX" - Prefix from name components "RTN","DGQEUT1",74,0) ; "STREET1" - Line 1 of mailing address "RTN","DGQEUT1",75,0) ; "STREET2" - Line 2 of mailing address "RTN","DGQEUT1",76,0) ; "STREET3" - Line 3 of mailing address "RTN","DGQEUT1",77,0) ; "CITY" - Mailing address city "RTN","DGQEUT1",78,0) ; "STATE" - Mailing address state "RTN","DGQEUT1",79,0) ; "ZIP" - Mailing address ZIP code "RTN","DGQEUT1",80,0) ; "ADRTYPE" - Mailing address type "RTN","DGQEUT1",81,0) ; [0:unable to determine,1:permanent, "RTN","DGQEUT1",82,0) ; 2:temporary,3:confidential,4:facility] "RTN","DGQEUT1",83,0) ; "ICN" - Integration Control Number "RTN","DGQEUT1",84,0) ; "FACNUM" - Local Station number "RTN","DGQEUT1",85,0) ; "FACNAME" - Local Facility name "RTN","DGQEUT1",86,0) ; "VISN" - Local Facility's VISN "RTN","DGQEUT1",87,0) ; "RTN","DGQEUT1",88,0) N DGRSLT "RTN","DGQEUT1",89,0) ; "RTN","DGQEUT1",90,0) S DGRSLT=0 "RTN","DGQEUT1",91,0) ; "RTN","DGQEUT1",92,0) I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D ;drop out of block on first failure "RTN","DGQEUT1",93,0) . ; "RTN","DGQEUT1",94,0) . ;get name, ssn, dob, dfn "RTN","DGQEUT1",95,0) . Q:'$$GETIDS^DGQEDEMO(DGDFN,.DGPAT) "RTN","DGQEUT1",96,0) . ; "RTN","DGQEUT1",97,0) . ;format Date of Birth to mmddyyyy "RTN","DGQEUT1",98,0) . S DGPAT("DOB")=$TR($$FMTE^XLFDT(DGPAT("DOB"),"5Z"),"/","") "RTN","DGQEUT1",99,0) . ; "RTN","DGQEUT1",100,0) . ;get name components "RTN","DGQEUT1",101,0) . Q:'$$GETNAMC^DGQEDEMO(DGDFN,.DGPAT) "RTN","DGQEUT1",102,0) . ; "RTN","DGQEUT1",103,0) . ;get mailing address "RTN","DGQEUT1",104,0) . Q:'$$GETADDR^DGQEDEMO(DGDFN,.DGPAT) "RTN","DGQEUT1",105,0) . ; "RTN","DGQEUT1",106,0) . ;get national ICN "RTN","DGQEUT1",107,0) . S DGPAT("ICN")=$$GETICN^DGQEDEMO(DGDFN) "RTN","DGQEUT1",108,0) . ; "RTN","DGQEUT1",109,0) . ;get facility info "RTN","DGQEUT1",110,0) . D GETSITE^DGQEDEMO(.DGPAT) "RTN","DGQEUT1",111,0) . ; "RTN","DGQEUT1",112,0) . ;success "RTN","DGQEUT1",113,0) . S DGRSLT=1 "RTN","DGQEUT1",114,0) ; "RTN","DGQEUT1",115,0) Q DGRSLT "RTN","DGQEUT1",116,0) ; "RTN","DGQEUT1",117,0) GETELIG(DGDFN,DGELG) ;build Patient Eligibility object "RTN","DGQEUT1",118,0) ; This function retrieves patient data needed to determine the "RTN","DGQEUT1",119,0) ; patient's VIC eligibility and returns the data in an array format. "RTN","DGQEUT1",120,0) ; "RTN","DGQEUT1",121,0) ; Supported References: "RTN","DGQEUT1",122,0) ; DBIA #10061: ELIG^VADPT "RTN","DGQEUT1",123,0) ; DBIA #2716: $$GETSTAT^DGMSTAPI "RTN","DGQEUT1",124,0) ; DBIA #4156: $$CVEDT^DGCV "RTN","DGQEUT1",125,0) ; "RTN","DGQEUT1",126,0) ; Input: "RTN","DGQEUT1",127,0) ; DGDFN - (required) pointer to patient in PATIENT (#2) file "RTN","DGQEUT1",128,0) ; "RTN","DGQEUT1",129,0) ; Output: "RTN","DGQEUT1",130,0) ; Function value - returns 1 on success, 0 on failure "RTN","DGQEUT1",131,0) ; DGELG - array of eligibility indicators, pass by reference "RTN","DGQEUT1",132,0) ; Array subscripts are: "RTN","DGQEUT1",133,0) ; "SC" - Service Connected indicator "RTN","DGQEUT1",134,0) ; "ENRSTAT" - Enrollment Status "RTN","DGQEUT1",135,0) ; "ELIGSTAT" - Eligibility Status "RTN","DGQEUT1",136,0) ; "MST" - Military Sexual Trauma Status "RTN","DGQEUT1",137,0) ; "COMBVET" - Combat Veteran Status "RTN","DGQEUT1",138,0) ; "POW" - Prisoner of War Indicator "RTN","DGQEUT1",139,0) ; "PH" - Purple Heart Indicator "RTN","DGQEUT1",140,0) ; "RTN","DGQEUT1",141,0) N DFN ;input parameter to ELIG^VADPT "RTN","DGQEUT1",142,0) N DGRSLT ;function value "RTN","DGQEUT1",143,0) N VAEL ;VADPT return array "RTN","DGQEUT1",144,0) N VAERR ;VADPT error value "RTN","DGQEUT1",145,0) ; "RTN","DGQEUT1",146,0) S DGRSLT=0 "RTN","DGQEUT1",147,0) ; "RTN","DGQEUT1",148,0) I $G(DGDFN)>0,$D(^DPT(DGDFN,0)) D "RTN","DGQEUT1",149,0) . ; "RTN","DGQEUT1",150,0) . ;get Eligibility Status and Service Connection "RTN","DGQEUT1",151,0) . S DFN=DGDFN "RTN","DGQEUT1",152,0) . D ELIG^VADPT "RTN","DGQEUT1",153,0) . S DGELG("ELIGSTAT")=$P($G(VAEL(8)),U) "RTN","DGQEUT1",154,0) . S DGELG("SC")=+$G(VAEL(3)) "RTN","DGQEUT1",155,0) . ; "RTN","DGQEUT1",156,0) . ;get current Enrollment Status "RTN","DGQEUT1",157,0) . S DGELG("ENRSTAT")=$$STATUS^DGENA(DGDFN) "RTN","DGQEUT1",158,0) . ; "RTN","DGQEUT1",159,0) . ;get MST Status "RTN","DGQEUT1",160,0) . S DGELG("MST")=$P($$GETSTAT^DGMSTAPI(DGDFN),U,2) "RTN","DGQEUT1",161,0) . ; "RTN","DGQEUT1",162,0) . ;get Combat Veteran Status "RTN","DGQEUT1",163,0) . S DGELG("COMBVET")=+$$CVEDT^DGCV(DGDFN) "RTN","DGQEUT1",164,0) . ; "RTN","DGQEUT1",165,0) . ;get Purple Heart Indicator "RTN","DGQEUT1",166,0) . S DGELG("PH")=$$GETPH(DGDFN) "RTN","DGQEUT1",167,0) . ; "RTN","DGQEUT1",168,0) . ;get POW indicator "RTN","DGQEUT1",169,0) . S DGELG("POW")=$S($$ISENRPND(DGELG("ENRSTAT")):"P",1:$$FNDPOW(.VAEL)) "RTN","DGQEUT1",170,0) . ; "RTN","DGQEUT1",171,0) . ;success "RTN","DGQEUT1",172,0) . S DGRSLT=1 "RTN","DGQEUT1",173,0) ; "RTN","DGQEUT1",174,0) Q DGRSLT "RTN","DGQEUT1",175,0) ; "RTN","DGQEUT1",176,0) GETPH(DGDFN) ;get purple heart indicator "RTN","DGQEUT1",177,0) ;This function retrieves the Current PH Indicator and Current PH "RTN","DGQEUT1",178,0) ;Status and returns a single interpretation value. "RTN","DGQEUT1",179,0) ; "RTN","DGQEUT1",180,0) ; Supported References: "RTN","DGQEUT1",181,0) ; DBIA #10061: SVC^VADPT "RTN","DGQEUT1",182,0) ; "RTN","DGQEUT1",183,0) ; Input: "RTN","DGQEUT1",184,0) ; DGDFN - pointer to patient in PATIENT (#2) file "RTN","DGQEUT1",185,0) ; "RTN","DGQEUT1",186,0) ; Output: "RTN","DGQEUT1",187,0) ; Function value - returns "Y" to print indicator on VIC; "N" to "RTN","DGQEUT1",188,0) ; not print indicator on VIC; "P" to hold request "RTN","DGQEUT1",189,0) ; until confirmation; "" when Registration interview "RTN","DGQEUT1",190,0) ; question is unanswered. "RTN","DGQEUT1",191,0) ; "RTN","DGQEUT1",192,0) N DFN ;input parameter to SVC^VADPT "RTN","DGQEUT1",193,0) N DGPHIND ;current purple heart indicator "RTN","DGQEUT1",194,0) N DGPHSTAT ;current purple heart status "RTN","DGQEUT1",195,0) N DGRSLT ;function value "RTN","DGQEUT1",196,0) N VAERR ;VADPT error value "RTN","DGQEUT1",197,0) N VASV ;VADPT return array "RTN","DGQEUT1",198,0) ; "RTN","DGQEUT1",199,0) S DGRSLT="" "RTN","DGQEUT1",200,0) ; "RTN","DGQEUT1",201,0) I $G(DGDFN)>0,$D(^DPT(DGDFN)) D "RTN","DGQEUT1",202,0) . ; "RTN","DGQEUT1",203,0) . ;get purple heart indicator and status "RTN","DGQEUT1",204,0) . S DFN=DGDFN "RTN","DGQEUT1",205,0) . D SVC^VADPT "RTN","DGQEUT1",206,0) . S DGPHIND=$G(VASV(9)) "RTN","DGQEUT1",207,0) . S DGPHSTAT=$P($G(VASV(9,1)),U,2) "RTN","DGQEUT1",208,0) . ; "RTN","DGQEUT1",209,0) . ;interpret status "RTN","DGQEUT1",210,0) . I DGPHIND=1 S DGRSLT=$S(DGPHSTAT="CONFIRMED":"Y",1:"P") "RTN","DGQEUT1",211,0) . I DGPHIND=0 S DGRSLT="N" "RTN","DGQEUT1",212,0) ; "RTN","DGQEUT1",213,0) Q DGRSLT "RTN","DGQEUT1",214,0) ; "RTN","DGQEUT1",215,0) GETPOW(DGDFN) ;get POW indicator "RTN","DGQEUT1",216,0) ;This function retrieves the eligibility codes for a given patient and "RTN","DGQEUT1",217,0) ;returns the POW indicator. "RTN","DGQEUT1",218,0) ; "RTN","DGQEUT1",219,0) ; Supported References: "RTN","DGQEUT1",220,0) ; DBIA #10061: ELIG^VADPT "RTN","DGQEUT1",221,0) ; "RTN","DGQEUT1",222,0) ; Input: "RTN","DGQEUT1",223,0) ; DGDFN - pointer to patient in PATIENT (#2) file "RTN","DGQEUT1",224,0) ; "RTN","DGQEUT1",225,0) ; Output: "RTN","DGQEUT1",226,0) ; Function value - returns results from call to $$FNDPOW "RTN","DGQEUT1",227,0) ; "RTN","DGQEUT1",228,0) N DFN "RTN","DGQEUT1",229,0) N VAEL ;VADPT result array "RTN","DGQEUT1",230,0) N VAERR ;VADPT error message "RTN","DGQEUT1",231,0) ; "RTN","DGQEUT1",232,0) S DFN=$G(DGDFN) "RTN","DGQEUT1",233,0) D ELIG^VADPT "RTN","DGQEUT1",234,0) ; "RTN","DGQEUT1",235,0) Q $$FNDPOW(.VAEL) "RTN","DGQEUT1",236,0) ; "RTN","DGQEUT1",237,0) FNDPOW(DGEL) ;find POW eligibility code "RTN","DGQEUT1",238,0) ;This function searches a list of eligibility codes for PRISONER OF "RTN","DGQEUT1",239,0) ;WAR and returns the boolean result. "RTN","DGQEUT1",240,0) ; "RTN","DGQEUT1",241,0) ; Input: "RTN","DGQEUT1",242,0) ; DGEL - result array from call to ELIG^VADPT "RTN","DGQEUT1",243,0) ; "RTN","DGQEUT1",244,0) ; Output: "RTN","DGQEUT1",245,0) ; Function value - returns "Y" when PRISONER OF WAR found; "RTN","DGQEUT1",246,0) ; otherwise "N" "RTN","DGQEUT1",247,0) ; "RTN","DGQEUT1",248,0) N DGEC ;eligibility code number "RTN","DGQEUT1",249,0) N DGRSLT ;function value "RTN","DGQEUT1",250,0) ; "RTN","DGQEUT1",251,0) S DGRSLT="N" "RTN","DGQEUT1",252,0) ; "RTN","DGQEUT1",253,0) ;Check primary eligibility code "RTN","DGQEUT1",254,0) I $P($G(DGEL(1)),U,2)="PRISONER OF WAR" Q "Y" "RTN","DGQEUT1",255,0) ; "RTN","DGQEUT1",256,0) S DGEC=0 "RTN","DGQEUT1",257,0) F S DGEC=$O(DGEL(1,DGEC)) Q:'DGEC D Q:DGRSLT="Y" "RTN","DGQEUT1",258,0) . I $P(DGEL(1,DGEC),U,2)="PRISONER OF WAR" S DGRSLT="Y" "RTN","DGQEUT1",259,0) ; "RTN","DGQEUT1",260,0) Q DGRSLT "RTN","DGQEUT1",261,0) ; "RTN","DGQEUT1",262,0) ISENRPND(DGST) ;is veteran's enrollment status pending? "RTN","DGQEUT1",263,0) ; "RTN","DGQEUT1",264,0) ; Input: "RTN","DGQEUT1",265,0) ; DGST - pointer to enrollment status in ENROLLMENT STATUS (#27.15) "RTN","DGQEUT1",266,0) ; file. "RTN","DGQEUT1",267,0) ; "RTN","DGQEUT1",268,0) ; Output: "RTN","DGQEUT1",269,0) ; Function value - returns 1 when status is pending; otherwise 0 "RTN","DGQEUT1",270,0) ; "RTN","DGQEUT1",271,0) S DGST=+$G(DGST) "RTN","DGQEUT1",272,0) Q $S('DGST:1,DGST=1:1,DGST=15:1,DGST=16:1,DGST=17:1,DGST=18:1,1:0) "VER") 8.0^22.0 "BLD",6977,6) ^655 **END** **END**