DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM,HM,BDB,ARF,RN,JAM - PATIENT INQUIRY (NEW) ; Feb 15, 2023@10:25
;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,688,887,907,925,936,940,941,987,1006,1056,1061,1059,1071,1064,1086,1095**;Aug 13, 1993;Build 23
; *286* Newing variables X,Y in OKLINE subroutine
; *358* If a patient is on a domiciliary ward, don't display MEANS
; TEST required/Medication Copayment Exemption messages
; *436* If an inpatient is not on a domiciliary ward, don't display
; Medication Copayment Exemption message
; *545* Add death information near the remarks field
; *677* Added Emergency Response
; *688* Modified to display Country and Foreign Address
; *936* Modified to display Health Benefit Plans
; *940* #879316,#879318 - Display Permanent & Total Disabled Status
; *941* #887088 - Redesign of Inquiry Screen layout for displaying the addresses
;
; Integration Agreements:
; 6138 - DGHBPUTL API
;
; Reference to DIS^EASECU in ICR #6771
SEL K DFN,DGRPOUT W ! S DIC="^DPT(",DIC(0)="AEQMZ" D ^DIC G Q:Y'>0 S DFN=+Y N Y W ! S DIR(0)="E" D ^DIR G SEL:$D(DTOUT)!($D(DUOUT)) D EN G SEL
EN ;call to display patient inquiry - input DFN
;MPI/PD CHANGE
S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1
;JAM begin changes Patch DG*5.3*941 add .115 and new address fields layout
F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3,.115 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
;jam DG*5.3*925 RM#788099 change labels to "Permanent Mailing Address" and "Temporary Mailing Address"
;
W " Residential Address: "
W ?40,"Mailing Address: " ;DG*5.3*1056 remove Permanent from the address label
S DGAD=.115,(DGA1,DGA2)=1 D AL^DGRPU(35) S DGAD=.11,DGA1=1,DGA2=2 D AL^DGRPU(35)
W !?5
N Z,Z1
S Z1=39,Z=$S($D(DGA(1)):DGA(1),1:"NONE ON FILE") D WW1^DGRPV W $S($D(DGA(2)):DGA(2),1:"NO PERMANENT MAILING ADDRESS")
; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
N DGCC
S DGCC=$$COUNTY^DGRPCADD(.DGRP,.115) ; print County if applicable
W !?5,"County: "_DGCC
S DGCC=$$COUNTY^DGRPCADD(.DGRP,.11) ; print County if applicable
W ?44,"County: "_DGCC
W !?6,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU)
W ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
W !?5,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
W ?46,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
W !?44,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
W !!
K DGA,DGA1,DGA2
I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,(DGA1,DGA2)=1 D AL^DGRPU(30)
N CONACT
; set Confidential Active Flag
S CONACT=$P(DGRP(.141),"^",9)
I CONACT="Y" D
.; check the begin/end dates, set active flag to NO and do not display if outside the date range
.N DGCABEG,DGCAEND,DGI
.S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
.I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) S CONACT="N" Q
.S DGAD=.141,DGA1=1,DGA2=2 D AL^DGRPU(30)
W " Temporary Mailing Address: "
W ?40,"Confidential Mailing Address: "
W !?5
W $S($D(DGA(1)):DGA(1),1:"NO TEMPORARY MAILING ADDRESS") W ?44,$S($D(DGA(2)):DGA(2),1:"NONE ON FILE")
; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
S I=2 F I1=0:0 S I=$O(DGA(I)) Q:I="" W:(I#2)!($X>40) !?5 W:'(I#2) ?44 W DGA(I)
W !
I $D(DGA(1)) D
.S DGCC=$$COUNTY^DGRPCADD(.DGRP,.121) ; print County if applicable
.W ?5,"County: "_DGCC
I $D(DGA(2)) D
.S DGCC=$$COUNTY^DGRPCADD(.DGRP,.141) ; print County if applicable
.W ?44,"County: "_DGCC
;W !?2,"CASS Cert: "_$S($P(DGRP(.121),U,15)="Y":"Certified",$P(DGRP(.121),U,15)="F":"Failed",1:"NC")
;W ?41,"CASS Cert: "_$S($P(DGRP(.141),U,17)="Y":"Certified",$P(DGRP(.141),U,17)="F":"Failed",1:"NC")
W !?6,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
W ?45,"Phone: ",$S($P(DGRP(.141),U,9)'="Y":"NOT APPLICABLE",CONACT'="Y":"NOT APPLICABLE",$P(DGRP(.13),U,15)]"":$P(DGRP(.13),U,15),1:DGRPU)
S X="NOT APPLICABLE"
I $P(DGRP(.121),U,9)="Y" D
.S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD")
.S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD")
.S X=X_$S(Y]"":Y,1:DGRPU)
N DGACT,DGTYP,DGCAN,DGBEG,DGEND,DGZ,DGXX,DGX,DGTYPNAM,DGCAT
W !?2,"From/To: ",X
S DGX="NOT APPLICABLE"
I CONACT="Y" D
.S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
..I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
..I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
W ?43,"From/To: "_DGX
W !?41,"Confidential Address Categories: " I $D(^DPT(DFN,.14)) D
.; If not active, do not display categories
.I CONACT'="Y" Q
.S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
.S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D
..Q:'$D(^DPT(DFN,.14,DGCAN,0))
..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D
...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
S DGXX="" F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D
.W !?42,DGXX
;
I '$$OKLINE^DGRPD1(16) G Q
N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
I 'DGABBRV W !!?4,"POS: ",$S($D(^DIC(21,+$P(DGRP(.32),"^",3),0)):$P(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$S($P(DGRP(.31),"^",3)]"":$P(DGRP(.31),"^",3),1:"UNSPECIFIED")
I 'DGABBRV W !?2,"Relig: ",$S($D(^DIC(13,+$P(DGRP(0),"^",8),0)):$P(^(0),"^",1),1:DGRPU),?46 ;,"Birth Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") ; DG*5.3*907
;**159 REMOVE CONDITIONAL DISPLAY OF BIRTH SEX AND GROUP WITH OTHER SOGI FIELDS
I 'DGABBRV W ! D
.N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
.K ^UTILITY($J,"W")
.S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D
..S VAL=+$G(^DPT(DFN,.02,PTR,0))
..Q:$$INACTIVE^DGUTL4(VAL,1)
..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
.M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
.K ^UTILITY($J,"W")
.S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D
..S VAL=+$G(^DPT(DFN,.06,PTR,0))
..Q:$$INACTIVE^DGUTL4(VAL,2)
..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
.M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
.K ^UTILITY($J,"W")
.W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
.F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
I '$$OKLINE^DGRPD1(16) G Q
;**1059 ADDING SOGI fields including BIRTH SEX
D SOGI
D LANGUAGE
I '$$OKLINE^DGRPD1(10) G Q
;display cv status #4156
N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
W !!,?2,"Combat Vet Status: "_$S($P(DGCV,U,3)=1:"ELIGIBLE",$P(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED") I DGCV>0 W ?45,"End Date: "_$$FMTE^XLFDT($P(DGCV,U,2),"5DZ")
;DG*5.3*1061 Display COMPACT ACT status only if TRUE
N DGKEY,DGREQNAME,DGRESP,DGCOMP,ELIGSEQ
S ELIG="UNDETERMINED",(DGCOMP,DGKEY,DGREQNAME,DGRESP,ELIGSEQ)=""
;make call to determine patient eligibility
S DGKEY=$$GETICN^MPIF001(DFN),DGREQNAME="VistADataVTwo"
I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
;if it returns zero, check PATIENT file for Compact Act eligible code
I $P(DGRESP,"^",1)=0 D
. S ELIGSEQ=""
. F S ELIGSEQ=$O(^DPT(DFN,"E",ELIGSEQ)) Q:(ELIGSEQ="")!(ELIGSEQ="B")!(ELIG="ELIGIBLE") D
. . I $P($G(^DIC(8,ELIGSEQ,0)),"^",1)="COMPACT ACT ELIGIBLE" S ELIG="ELIGIBLE"
. . Q
. Q
I $P(DGRESP,"^",1)=1 D
. I DGCOMP="No" S ELIG="NOT ELIGIBLE"
. I DGCOMP="Yes" S ELIG="ELIGIBLE"
W !,?1,"COMPACT Act Status: "_ELIG
;
;display primary eligibility
S X1=DGRP(.36),X=$P(DGRP(.361),"^",1) W !,"Primary Eligibility: ",$S($D(^DIC(8,+X1,0)):$P(^(0),"^",1)_" ("_$S(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
W !,"Other Eligibilities: "
S I="",X=""
F S I=$O(^DPT("AEL",DFN,I)) Q:I="" D
. I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^DIC(8,I,0),"^",1)_", "
. I $O(^DPT("AEL",DFN,I))="" S X=$E(X,1,$L(X)-2)
. W:$X+$L(X)>79 !?21 W X
. Q
I '$$OKLINE^DGRPD1(16) G Q
;employability status
W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
I '$$OKLINE^DGRPD1(19) G Q
; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status
W !?6,"Permanent & Total Disabled: ",$S($P(DGRP(.3),U,4)="Y":"YES",1:"NO")
I '$$OKLINE^DGRPD1(19) G Q
;display the catastrophic disability review date if there is one
D CATDIS^DGRPD1
I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D
. N DGPDT,DGPTM
. W !,$$REPEAT^XLFSTR("-",78)
. S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
. W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
. S DGPTM=$$PCTEAM^DGSDUTL(DFN)
. I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
. W !,$$REPEAT^XLFSTR("-",78)
;jam; DG*5.3*1064
I $$INDSTATUS^DGENELA2(DFN) W !,$$EZBLD^DIALOG(261133)
;
; Check if patient is an inpatient and on a DOM ward
; If inpatient is on a DOM ward, don't display MT or CP messages
; If inpatient is NOT on a DOM ward, don't display CP message
N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
G Q:'$$OKLINE^DGRPD1(16)
D DOM^DGMTR
I '$G(DGDOM) D
.D DIS^DGMTU(DFN)
.D IN5^VADPT
.I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518)
S VAIP("L")=""
I $$OKLINE^DGRPD1(14) D INP
I '$G(DGRPOUT),($$OKLINE^DGRPD1(10)) D SA ;*KNR*
;MPI/PD CHANGE
Q D KVA^VADPT K %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y Q
;
INP S VAIP("D")="L" D INP^DGPMV10
S DGPMT=0
D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
SA F I=0:0 S I=$O(^DGS(41.1,"B",DFN,I)) G CL:'I S X=^DGS(41.1,I,0) I $P(X,"^",2)>(DT-1),$P(X,"^",13)']"",'$P(X,"^",17) S L=$P(X,"^",2) D:$$OKLINE^DGRPD1(17) SAA Q:$G(DGRPOUT)
Q
SAA ;Scheduled Admit Data
W !!?14,"Scheduled Admit"
W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
W " on "_$$FMTE^XLFDT(L,"5DZ")
Q ;SAA
;
CL G FA:$O(^DPT(DFN,"DE",0))="" S SDCT=0 F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:'I I $D(^(I,0)),$P(^(0),"^",2)'="I",$O(^(0)) S SDCT=SDCT+1 W:SDCT=1 !!,"Currently enrolled in " W:$X>50 !?22 W $S($D(^SC(+^(0),0)):$P(^(0),"^",1)_", ",1:"")
;
FA ;
N DGARRAY,SDCNT
S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
;if there is lower subscripts hanging from the 101 node,
;then it is a valid appointment, otherwise it is
;an error eg 01/20/2005
;G:'$$OKLINE^DGRPD1(13) RMK ;*///*
I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
;
W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5
.N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
.S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
..D COV
..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
..Q
I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(15)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;*///*
D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
W !!
W "Date of Death Information"
W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
I $$OKLINE^DGRPD1(14) D EC^DGRPD1
; KUM DG*5.3*936 Call tag to display Health Benefit Plans assigned to Veteran
D HBP
K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
Q
; KUM DG*5.3*936 Display Health Benefit Plans assigned to Veteran
HBP ;W !!,"Veteran Medical Benefit Plan Currently Assigned to Veteran:" ;DG*5.3*987 HM
W !!,"VHA Profiles Currently Assigned to Veteran:" ;DG*5.3*1006 BDB;DG*5.3*987 HM
N DGHBP,HBP,DGCOUNT,DGHBIEN,DGPNAME,X,DGCNT,DGLN,DGLINE
S DGCOUNT=0
D GETHBP^DGHBPUTL(DFN)
S DGHBP="" F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D
.; DG*5.3*987; jam; Place "zz" before the plan name for inactive plans
.S DGHBIEN=+HBP("CUR",DGHBP)
.I $P($G(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y" S DGPNAME="zz "_DGHBP
.E S DGPNAME=DGHBP
.; DG*5.3*987; arf; Add word wrapping for plan names
.S X=DGPNAME
.K ^UTILITY($J,"W") S DIWL=0,DIWR=70,DIWF="" D ^DIWP
.S DGCNT=^UTILITY($J,"W",0)
.F DGLN=1:1:DGCNT S DGLINE=^UTILITY($J,"W",0,DGLN,0) W !,?3,DGLINE
.K ^UTILITY($J,"W")
.S DGCOUNT=DGCOUNT+1
I DGCOUNT=0 W !,?3,"None"
Q
;
COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
Q
;
OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
Q
LANGUAGE ; Get language data *///*
S DGLANGDT=9999999,(DGPRFLAN,DGLANG0)=""
S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1)
I DGLANGDT="" G L1
S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0))
S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2)
S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y
L1 W !!,"Language Date/Time: ",$S(DGLANGDT="":"UNANSWERED",1:DGLANGDT),!
W ?1,"Preferred Language: ",$S(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN)
K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
Q
SOGI ;**1059 SOGI FIELDS TO BE DISPLAYED VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121
;**1071 VAMPI-13755 (jfw) - Display Additional SO Info
N EN,SXO,PRN
W !,"Birth Sex : ",$$GET1^DIQ(2,DFN,".02","E")
;SEXUAL ORIENTATION
W !,"Sexual Orientation: "
S EN=0 F S EN=$O(^DPT(DFN,.025,EN)) Q:'EN I $P($G(^(EN,0)),"^",2)="A" D
.N DGSOI D GETS^DIQ(2.025,EN_","_DFN,"*",,"DGSOI")
.W !?20,DGSOI(2.025,EN_","_DFN_",",.01)_" ("_DGSOI(2.025,EN_","_DFN_",",.02)_")"
.W !?25,"Date Created:",?44,DGSOI(2.025,EN_","_DFN_",",.03)
.W !?25,"Date Last Updated: "_DGSOI(2.025,EN_","_DFN_",",.04)
W !,"Sexual Orientation Description: ",$$GET1^DIQ(2,DFN,".0251","E")
W !,"Pronoun: "
S EN=0 F S EN=$O(^DPT(DFN,.2406,EN)) Q:'EN D
.S PRN=$G(^DPT(DFN,.2406,EN,0))
.W !?20,$P($G(^DG(47.78,PRN,0)),"^")
W !,"Pronoun Description: ",$$GET1^DIQ(2,DFN,".24061","E")
W !,"Self-Identified Gender Identity: ",$$GET1^DIQ(2,DFN,".024","E")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPD 15308 printed Apr 09, 2024@22:06:30 Page 2
DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM,HM,BDB,ARF,RN,JAM - PATIENT INQUIRY (NEW) ; Feb 15, 2023@10:25
+1 ;;5.3;Registration;**109,124,121,57,161,149,286,358,436,445,489,498,506,513,518,550,545,568,585,677,703,688,887,907,925,936,940,941,987,1006,1056,1061,1059,1071,1064,1086,1095**;Aug 13, 1993;Build 23
+2 ; *286* Newing variables X,Y in OKLINE subroutine
+3 ; *358* If a patient is on a domiciliary ward, don't display MEANS
+4 ; TEST required/Medication Copayment Exemption messages
+5 ; *436* If an inpatient is not on a domiciliary ward, don't display
+6 ; Medication Copayment Exemption message
+7 ; *545* Add death information near the remarks field
+8 ; *677* Added Emergency Response
+9 ; *688* Modified to display Country and Foreign Address
+10 ; *936* Modified to display Health Benefit Plans
+11 ; *940* #879316,#879318 - Display Permanent & Total Disabled Status
+12 ; *941* #887088 - Redesign of Inquiry Screen layout for displaying the addresses
+13 ;
+14 ; Integration Agreements:
+15 ; 6138 - DGHBPUTL API
+16 ;
+17 ; Reference to DIS^EASECU in ICR #6771
SEL KILL DFN,DGRPOUT
WRITE !
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
DO ^DIC
if Y'>0
GOTO Q
SET DFN=+Y
NEW Y
WRITE !
SET DIR(0)="E"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
GOTO SEL
DO EN
GOTO SEL
EN ;call to display patient inquiry - input DFN
+1 ;MPI/PD CHANGE
+2 SET DGCMOR="UNSPECIFIED"
SET DGMPI=$GET(^DPT(+DFN,"MPI"))
+3 KILL DGRPOUT,DGHOW
SET DGABBRV=$SELECT($DATA(^DG(43,1,0)):+$PIECE(^(0),"^",38),1:0)
SET DGRPU="UNSPECIFIED"
DO DEM^VADPT
DO HDR^DGRPD1
+4 ;JAM begin changes Patch DG*5.3*941 add .115 and new address fields layout
+5 FOR I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3,.115
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+6 ;jam DG*5.3*925 RM#788099 change labels to "Permanent Mailing Address" and "Temporary Mailing Address"
+7 ;
+8 WRITE " Residential Address: "
+9 ;DG*5.3*1056 remove Permanent from the address label
WRITE ?40,"Mailing Address: "
+10 SET DGAD=.115
SET (DGA1,DGA2)=1
DO AL^DGRPU(35)
SET DGAD=.11
SET DGA1=1
SET DGA2=2
DO AL^DGRPU(35)
+11 WRITE !?5
+12 NEW Z,Z1
+13 SET Z1=39
SET Z=$SELECT($DATA(DGA(1)):DGA(1),1:"NONE ON FILE")
DO WW1^DGRPV
WRITE $SELECT($DATA(DGA(2)):DGA(2),1:"NO PERMANENT MAILING ADDRESS")
+14 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
+15 SET I=2
FOR I1=0:0
SET I=$ORDER(DGA(I))
if I=""
QUIT
if (I#2)!($X>40)
WRITE !?5
if '(I#2)
WRITE ?44
WRITE DGA(I)
+16 NEW DGCC
+17 ; print County if applicable
SET DGCC=$$COUNTY^DGRPCADD(.DGRP,.115)
+18 WRITE !?5,"County: "_DGCC
+19 ; print County if applicable
SET DGCC=$$COUNTY^DGRPCADD(.DGRP,.11)
+20 WRITE ?44,"County: "_DGCC
+21 WRITE !?6,"Phone: ",$SELECT($PIECE(DGRP(.13),U,1)]"":$PIECE(DGRP(.13),U,1),1:DGRPU)
+22 WRITE ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$PIECE(DGRP(.11),U,16))
+23 WRITE !?5,"Office: ",$SELECT($PIECE(DGRP(.13),U,2)]"":$PIECE(DGRP(.13),U,2),1:DGRPU)
+24 WRITE ?46,"Cell: ",$SELECT($PIECE(DGRP(.13),U,4)]"":$PIECE(DGRP(.13),U,4),1:DGRPU)
+25 WRITE !?44,"E-mail: ",$SELECT($PIECE(DGRP(.13),U,3)]"":$PIECE(DGRP(.13),U,3),1:DGRPU)
+26 WRITE !!
+27 KILL DGA,DGA1,DGA2
+28 IF $PIECE(DGRP(.121),"^",9)="Y"
SET DGAD=.121
SET (DGA1,DGA2)=1
DO AL^DGRPU(30)
+29 NEW CONACT
+30 ; set Confidential Active Flag
+31 SET CONACT=$PIECE(DGRP(.141),"^",9)
+32 IF CONACT="Y"
Begin DoDot:1
+33 ; check the begin/end dates, set active flag to NO and do not display if outside the date range
+34 NEW DGCABEG,DGCAEND,DGI
+35 SET DGCABEG=$PIECE(DGRP(.141),U,7)
SET DGCAEND=$PIECE(DGRP(.141),U,8)
+36 IF 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT))
SET CONACT="N"
QUIT
+37 SET DGAD=.141
SET DGA1=1
SET DGA2=2
DO AL^DGRPU(30)
End DoDot:1
+38 WRITE " Temporary Mailing Address: "
+39 WRITE ?40,"Confidential Mailing Address: "
+40 WRITE !?5
+41 WRITE $SELECT($DATA(DGA(1)):DGA(1),1:"NO TEMPORARY MAILING ADDRESS")
WRITE ?44,$SELECT($DATA(DGA(2)):DGA(2),1:"NONE ON FILE")
+42 ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
+43 SET I=2
FOR I1=0:0
SET I=$ORDER(DGA(I))
if I=""
QUIT
if (I#2)!($X>40)
WRITE !?5
if '(I#2)
WRITE ?44
WRITE DGA(I)
+44 WRITE !
+45 IF $DATA(DGA(1))
Begin DoDot:1
+46 ; print County if applicable
SET DGCC=$$COUNTY^DGRPCADD(.DGRP,.121)
+47 WRITE ?5,"County: "_DGCC
End DoDot:1
+48 IF $DATA(DGA(2))
Begin DoDot:1
+49 ; print County if applicable
SET DGCC=$$COUNTY^DGRPCADD(.DGRP,.141)
+50 WRITE ?44,"County: "_DGCC
End DoDot:1
+51 ;W !?2,"CASS Cert: "_$S($P(DGRP(.121),U,15)="Y":"Certified",$P(DGRP(.121),U,15)="F":"Failed",1:"NC")
+52 ;W ?41,"CASS Cert: "_$S($P(DGRP(.141),U,17)="Y":"Certified",$P(DGRP(.141),U,17)="F":"Failed",1:"NC")
+53 WRITE !?6,"Phone: ",$SELECT($PIECE(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$PIECE(DGRP(.121),U,10)]"":$PIECE(DGRP(.121),U,10),1:DGRPU)
+54 WRITE ?45,"Phone: ",$SELECT($PIECE(DGRP(.141),U,9)'="Y":"NOT APPLICABLE",CONACT'="Y":"NOT APPLICABLE",$PIECE(DGRP(.13),U,15)]"":$PIECE(DGRP(.13),U,15),1:DGRPU)
+55 SET X="NOT APPLICABLE"
+56 IF $PIECE(DGRP(.121),U,9)="Y"
Begin DoDot:1
+57 SET Y=$PIECE(DGRP(.121),U,7)
if Y]""
XECUTE ^DD("DD")
+58 SET X=$SELECT(Y]"":Y,1:DGRPU)_"-"
SET Y=$PIECE(DGRP(.121),U,8)
if Y]""
XECUTE ^DD("DD")
+59 SET X=X_$SELECT(Y]"":Y,1:DGRPU)
End DoDot:1
+60 NEW DGACT,DGTYP,DGCAN,DGBEG,DGEND,DGZ,DGXX,DGX,DGTYPNAM,DGCAT
+61 WRITE !?2,"From/To: ",X
+62 SET DGX="NOT APPLICABLE"
+63 IF CONACT="Y"
Begin DoDot:1
+64 SET (DGZ,DGX)=""
FOR DGI=7,8
SET DGZ=$PIECE(DGRP(.141),"^",DGI)
SET Y=DGZ
Begin DoDot:2
+65 IF DGI=7
if Y]""
XECUTE ^DD("DD")
SET DGBEG=Y
SET DGX=Y
+66 IF DGI=8
if Y]""
XECUTE ^DD("DD")
SET DGEND=Y
SET DGX=DGX_"-"_$SELECT(Y]"":Y,1:"UNANSWERED")
End DoDot:2
End DoDot:1
+67 WRITE ?43,"From/To: "_DGX
+68 WRITE !?41,"Confidential Address Categories: "
IF $DATA(^DPT(DFN,.14))
Begin DoDot:1
+69 ; If not active, do not display categories
+70 IF CONACT'="Y"
QUIT
+71 SET DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
+72 SET DGX=""
SET DGCAN=""
FOR
SET DGCAN=$ORDER(^DPT(DFN,.14,DGCAN))
if DGCAN=""
QUIT
Begin DoDot:2
+73 if '$DATA(^DPT(DFN,.14,DGCAN,0))
QUIT
+74 SET DGTYP=$PIECE(^DPT(DFN,.14,DGCAN,0),"^",1)
SET DGACT=$PIECE(^DPT(DFN,.14,DGCAN,0),"^",2)
+75 SET DGACT=$SELECT(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
+76 SET DGTYPNAM=""
FOR DGI=1:1
SET DGTYPNAM=$PIECE(DGCAT,";",DGI)
if DGTYPNAM=""
QUIT
Begin DoDot:3
+77 IF DGTYPNAM[DGTYP
SET DGTYPNAM=$PIECE(DGTYPNAM,":",2)
SET DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
End DoDot:3
End DoDot:2
End DoDot:1
+78 SET DGXX=""
FOR DGI=1:1
SET DGXX=$PIECE(DGX,",",DGI)
if DGXX=""
QUIT
Begin DoDot:1
+79 WRITE !?42,DGXX
End DoDot:1
+80 ;
+81 IF '$$OKLINE^DGRPD1(16)
GOTO Q
+82 NEW DGEMER
SET DGEMER=$$EXTERNAL^DILFD(2,.181,"",$PIECE($GET(^DPT(DFN,.18)),"^"))
+83 if DGEMER]""
WRITE !?32,"Emergency Response: ",DGEMER
+84 IF 'DGABBRV
WRITE !!?4,"POS: ",$SELECT($DATA(^DIC(21,+$PIECE(DGRP(.32),"^",3),0)):$PIECE(^(0),"^",1),1:DGRPU),?42,"Claim #: ",$SELECT($PIECE(DGRP(.31),"^",3)]"":$PIECE(DGRP(.31),"^",3),1:"UNSPECIFIED")
+85 ;,"Birth Sex: ",$S($P(VADM(5),"^",2)]"":$P(VADM(5),"^",2),1:"UNSPECIFIED") ; DG*5.3*907
IF 'DGABBRV
WRITE !?2,"Relig: ",$SELECT($DATA(^DIC(13,+$PIECE(DGRP(0),"^",8),0)):$PIECE(^(0),"^",1),1:DGRPU),?46
+86 ;**159 REMOVE CONDITIONAL DISPLAY OF BIRTH SEX AND GROUP WITH OTHER SOGI FIELDS
+87 IF 'DGABBRV
WRITE !
Begin DoDot:1
+88 NEW RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
+89 KILL ^UTILITY($JOB,"W")
+90 SET PTR=0
FOR
SET PTR=+$ORDER(^DPT(DFN,.02,PTR))
if 'PTR
QUIT
Begin DoDot:2
+91 SET VAL=+$GET(^DPT(DFN,.02,PTR,0))
+92 if $$INACTIVE^DGUTL4(VAL,1)
QUIT
+93 SET VAL=$$PTR2TEXT^DGUTL4(VAL,1)
if +$ORDER(^DPT(DFN,.02,PTR))
SET VAL=VAL_", "
+94 SET X=VAL
SET DIWL=0
SET DIWR=30
SET DIWF=""
DO ^DIWP
End DoDot:2
+95 MERGE RACE=^UTILITY($JOB,"W",0)
if $GET(RACE(1,0))=""
SET RACE(1,0)="UNANSWERED"
+96 KILL ^UTILITY($JOB,"W")
+97 SET PTR=0
FOR
SET PTR=+$ORDER(^DPT(DFN,.06,PTR))
if 'PTR
QUIT
Begin DoDot:2
+98 SET VAL=+$GET(^DPT(DFN,.06,PTR,0))
+99 if $$INACTIVE^DGUTL4(VAL,2)
QUIT
+100 SET VAL=$$PTR2TEXT^DGUTL4(VAL,2)
if +$ORDER(^DPT(DFN,.06,PTR))
SET VAL=VAL_", "
+101 SET X=VAL
SET DIWL=0
SET DIWR=30
SET DIWF=""
DO ^DIWP
End DoDot:2
+102 MERGE ETHNIC=^UTILITY($JOB,"W",0)
if $GET(ETHNIC(1,0))=""
SET ETHNIC(1,0)="UNANSWERED"
+103 KILL ^UTILITY($JOB,"W")
+104 WRITE ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
+105 FOR X=2:1
if '$DATA(RACE(X,0))&'$DATA(ETHNIC(X,0))
QUIT
WRITE !,?9,$GET(RACE(X,0)),?51,$GET(ETHNIC(X,0))
End DoDot:1
+106 IF '$$OKLINE^DGRPD1(16)
GOTO Q
+107 ;**1059 ADDING SOGI fields including BIRTH SEX
+108 DO SOGI
+109 DO LANGUAGE
+110 IF '$$OKLINE^DGRPD1(10)
GOTO Q
+111 ;display cv status #4156
+112 NEW DGCV
SET DGCV=$$CVEDT^DGCV(+DFN)
+113 WRITE !!,?2,"Combat Vet Status: "_$SELECT($PIECE(DGCV,U,3)=1:"ELIGIBLE",$PIECE(DGCV,U,3)="":"NOT ELIGIBLE",1:"EXPIRED")
IF DGCV>0
WRITE ?45,"End Date: "_$$FMTE^XLFDT($PIECE(DGCV,U,2),"5DZ")
+114 ;DG*5.3*1061 Display COMPACT ACT status only if TRUE
+115 NEW DGKEY,DGREQNAME,DGRESP,DGCOMP,ELIGSEQ
+116 SET ELIG="UNDETERMINED"
SET (DGCOMP,DGKEY,DGREQNAME,DGRESP,ELIGSEQ)=""
+117 ;make call to determine patient eligibility
+118 SET DGKEY=$$GETICN^MPIF001(DFN)
SET DGREQNAME="VistADataVTwo"
+119 IF $PIECE(DGKEY,"^",1)'=-1
SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,"","",.DGCOMP)
+120 ;if it returns zero, check PATIENT file for Compact Act eligible code
+121 IF $PIECE(DGRESP,"^",1)=0
Begin DoDot:1
+122 SET ELIGSEQ=""
+123 FOR
SET ELIGSEQ=$ORDER(^DPT(DFN,"E",ELIGSEQ))
if (ELIGSEQ="")!(ELIGSEQ="B")!(ELIG="ELIGIBLE")
QUIT
Begin DoDot:2
+124 IF $PIECE($GET(^DIC(8,ELIGSEQ,0)),"^",1)="COMPACT ACT ELIGIBLE"
SET ELIG="ELIGIBLE"
+125 QUIT
End DoDot:2
+126 QUIT
End DoDot:1
+127 IF $PIECE(DGRESP,"^",1)=1
Begin DoDot:1
+128 IF DGCOMP="No"
SET ELIG="NOT ELIGIBLE"
+129 IF DGCOMP="Yes"
SET ELIG="ELIGIBLE"
End DoDot:1
+130 WRITE !,?1,"COMPACT Act Status: "_ELIG
+131 ;
+132 ;display primary eligibility
+133 SET X1=DGRP(.36)
SET X=$PIECE(DGRP(.361),"^",1)
WRITE !,"Primary Eligibility: ",$SELECT($DATA(^DIC(8,+X1,0)):$PIECE(^(0),"^",1)_" ("_$SELECT(X="V":"VERIFIED",X="P":"PENDING VERIFICATION",X="R":"PENDING REVERIFICATION",1:"NOT VERIFIED")_")",1:DGRPU)
+134 WRITE !,"Other Eligibilities: "
+135 SET I=""
SET X=""
+136 FOR
SET I=$ORDER(^DPT("AEL",DFN,I))
if I=""
QUIT
Begin DoDot:1
+137 IF $DATA(^DIC(8,I,0))
IF I'=+X1
SET X=$PIECE(^DIC(8,I,0),"^",1)_", "
+138 IF $ORDER(^DPT("AEL",DFN,I))=""
SET X=$EXTRACT(X,1,$LENGTH(X)-2)
+139 if $X+$LENGTH(X)>79
WRITE !?21
WRITE X
+140 QUIT
End DoDot:1
+141 IF '$$OKLINE^DGRPD1(16)
GOTO Q
+142 ;employability status
+143 WRITE !?6,"Unemployable: ",$SELECT($PIECE(DGRP(.3),U,5)="Y":"YES",1:"NO")
+144 IF '$$OKLINE^DGRPD1(19)
GOTO Q
+145 ; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status
+146 WRITE !?6,"Permanent & Total Disabled: ",$SELECT($PIECE(DGRP(.3),U,4)="Y":"YES",1:"NO")
+147 IF '$$OKLINE^DGRPD1(19)
GOTO Q
+148 ;display the catastrophic disability review date if there is one
+149 DO CATDIS^DGRPD1
+150 IF $GET(DGPRFLG)=1
if '$$OKLINE^DGRPD1(19)
GOTO Q
Begin DoDot:1
+151 NEW DGPDT,DGPTM
+152 WRITE !,$$REPEAT^XLFSTR("-",78)
+153 SET DGPDT=""
SET DGPDT=$ORDER(^DGS(41.41,"ADC",DFN,DGPDT),-1)
+154 WRITE !,"[PRE-REGISTER DATE:] "_$SELECT(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
+155 SET DGPTM=$$PCTEAM^DGSDUTL(DFN)
+156 IF $PIECE(DGPTM,U,2)]""
WRITE !,"[PRIMARY CARE TEAM:] "_$PIECE(DGPTM,U,2)
+157 WRITE !,$$REPEAT^XLFSTR("-",78)
End DoDot:1
+158 ;jam; DG*5.3*1064
+159 IF $$INDSTATUS^DGENELA2(DFN)
WRITE !,$$EZBLD^DIALOG(261133)
+160 ;
+161 ; Check if patient is an inpatient and on a DOM ward
+162 ; If inpatient is on a DOM ward, don't display MT or CP messages
+163 ; If inpatient is NOT on a DOM ward, don't display CP message
+164 NEW DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
+165 if '$$OKLINE^DGRPD1(16)
GOTO Q
+166 DO DOM^DGMTR
+167 IF '$GET(DGDOM)
Begin DoDot:1
+168 DO DIS^DGMTU(DFN)
+169 DO IN5^VADPT
+170 IF $GET(VAIP(1))=""
DO DISP^IBARXEU(DFN,DT,3,1)
End DoDot:1
+171 ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
+172 ;Added for LTC III (DG*5.3*518)
DO DIS^EASECU(DFN)
+173 SET VAIP("L")=""
+174 IF $$OKLINE^DGRPD1(14)
DO INP
+175 ;*KNR*
IF '$GET(DGRPOUT)
IF ($$OKLINE^DGRPD1(10))
DO SA
+176 ;MPI/PD CHANGE
Q DO KVA^VADPT
KILL %DT,D0,D1,DGA,DGA1,DGA2,DGABBRV,DGAD,DGCC,DGCMOR,DGDOM,DGLOCATN,DGMPI,DGRP,DGRPU,DGS,DGST,DGXFR0,DIC,DIR,DTOUT,DUOUT,DIRUT,DIROUT,I,I1,L,LDM,POP,SDCT,VA,X,X1,Y
QUIT
+1 ;
INP SET VAIP("D")="L"
DO INP^DGPMV10
+1 SET DGPMT=0
+2 DO CS^DGPMV10
KILL DGPMT,DGPMIFN
if '$DATA(DGSWITCH)
KILL DGPMVI,DGPMDCD
QUIT
SA FOR I=0:0
SET I=$ORDER(^DGS(41.1,"B",DFN,I))
if 'I
GOTO CL
SET X=^DGS(41.1,I,0)
IF $PIECE(X,"^",2)>(DT-1)
IF $PIECE(X,"^",13)']""
IF '$PIECE(X,"^",17)
SET L=$PIECE(X,"^",2)
if $$OKLINE^DGRPD1(17)
DO SAA
if $GET(DGRPOUT)
QUIT
+1 QUIT
SAA ;Scheduled Admit Data
+1 WRITE !!?14,"Scheduled Admit"
+2 if $DATA(^DIC(42,+$PIECE(X,U,8),0))
WRITE " on ward "_$PIECE(^(0),U)
+3 if $DATA(^DIC(45.7,+$PIECE(X,U,9),0))
WRITE " for treating specialty "_$PIECE(^(0),U)
+4 WRITE " on "_$$FMTE^XLFDT(L,"5DZ")
+5 ;SAA
QUIT
+6 ;
CL if $ORDER(^DPT(DFN,"DE",0))=""
GOTO FA
SET SDCT=0
FOR I=0:0
SET I=$ORDER(^DPT(DFN,"DE",I))
if 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),"^",2)'="I"
IF $ORDER(^(0))
SET SDCT=SDCT+1
if SDCT=1
WRITE !!,"Currently enrolled in "
if $X>50
WRITE !?22
WRITE $SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),"^",1)_", ",1:"")
+1 ;
FA ;
+1 NEW DGARRAY,SDCNT
+2 SET DGARRAY("FLDS")="1;2;3;18"
SET DGARRAY(4)=DFN
SET DGARRAY(1)=DT
SET DGARRAY("SORT")="P"
+3 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
SET CT=0
WRITE !!,"Future Appointments: "
+4 ;if there is lower subscripts hanging from the 101 node,
+5 ;then it is a valid appointment, otherwise it is
+6 ;an error eg 01/20/2005
+7 ;G:'$$OKLINE^DGRPD1(13) RMK ;*///*
+8 IF $DATA(^TMP($JOB,"SDAMA301",101))=1
WRITE "Appointment Database is Unavailable"
GOTO RMK
+9 IF $ORDER(^TMP($JOB,"SDAMA301",DFN,DT))'>0
WRITE "NONE"
GOTO RMK
+10 ;
+11 WRITE ?22,"Date",?33,"Time",?39,"Clinic",!?22
FOR I=22:1:75
WRITE "="
+12 FOR FA=DT:0
SET FA=$ORDER(^TMP($JOB,"SDAMA301",DFN,FA))
if 'FA
GOTO RMK
Begin DoDot:1
+13 NEW STAT
SET STAT=$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,3),";")
+14 SET C=+$PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,2)
IF STAT'["C"
Begin DoDot:2
+15 DO COV
+16 NEW DGAPPT
SET DGAPPT=$$FMTE^XLFDT($EXTRACT(FA,1,12),"5Z")
+17 WRITE !?22,$PIECE(DGAPPT,"@"),?33,$PIECE(DGAPPT,"@",2)
+18 WRITE ?39,$PIECE($PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
+19 QUIT
End DoDot:2
End DoDot:1
if CT>5
QUIT
+20 IF $ORDER(^TMP($JOB,"SDAMA301",DFN,FA))>0
WRITE !,"See Scheduling options for additional appointments."
RMK ;*///*
IF '$GET(DGRPOUT)
IF ($$OKLINE^DGRPD1(15))
WRITE !!,"Remarks: ",$PIECE(^DPT(DFN,0),"^",10)
+1 DO GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
+2 WRITE !!
+3 WRITE "Date of Death Information"
+4 WRITE !,?5,"Date of Death: ",$GET(PDTHINFO(2,DFN_",",.351,"E"))
+5 WRITE !,?5,"Source of Notification: ",$GET(PDTHINFO(2,DFN_",",.353,"E"))
+6 WRITE !,?5,"Updated Date/Time: ",$GET(PDTHINFO(2,DFN_",",.354,"E"))
+7 WRITE !,?5,"Last Edited By: ",$GET(PDTHINFO(2,DFN_",",.355,"E")),!
+8 IF $$OKLINE^DGRPD1(14)
DO EC^DGRPD1
+9 ; KUM DG*5.3*936 Call tag to display Health Benefit Plans assigned to Veteran
+10 DO HBP
+11 ;Y killed after dghinqky
KILL DGARRAY,SDCNT,^TMP($JOB,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I
+12 QUIT
+13 ; KUM DG*5.3*936 Display Health Benefit Plans assigned to Veteran
HBP ;W !!,"Veteran Medical Benefit Plan Currently Assigned to Veteran:" ;DG*5.3*987 HM
+1 ;DG*5.3*1006 BDB;DG*5.3*987 HM
WRITE !!,"VHA Profiles Currently Assigned to Veteran:"
+2 NEW DGHBP,HBP,DGCOUNT,DGHBIEN,DGPNAME,X,DGCNT,DGLN,DGLINE
+3 SET DGCOUNT=0
+4 DO GETHBP^DGHBPUTL(DFN)
+5 SET DGHBP=""
FOR
SET DGHBP=$ORDER(HBP("CUR",DGHBP))
if DGHBP=""
QUIT
Begin DoDot:1
+6 ; DG*5.3*987; jam; Place "zz" before the plan name for inactive plans
+7 SET DGHBIEN=+HBP("CUR",DGHBP)
+8 IF $PIECE($GET(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y"
SET DGPNAME="zz "_DGHBP
+9 IF '$TEST
SET DGPNAME=DGHBP
+10 ; DG*5.3*987; arf; Add word wrapping for plan names
+11 SET X=DGPNAME
+12 KILL ^UTILITY($JOB,"W")
SET DIWL=0
SET DIWR=70
SET DIWF=""
DO ^DIWP
+13 SET DGCNT=^UTILITY($JOB,"W",0)
+14 FOR DGLN=1:1:DGCNT
SET DGLINE=^UTILITY($JOB,"W",0,DGLN,0)
WRITE !,?3,DGLINE
+15 KILL ^UTILITY($JOB,"W")
+16 SET DGCOUNT=DGCOUNT+1
End DoDot:1
+17 IF DGCOUNT=0
WRITE !,?3,"None"
+18 QUIT
+19 ;
COV SET COV=$SELECT(+$PIECE(^TMP($JOB,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
+1 SET COV=COV_$SELECT(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:"")
SET CT=CT+1
QUIT
+2 QUIT
+3 ;
OREN SET XQORQUIT=1
if '$DATA(ORVP)
QUIT
SET DFN=+ORVP
DO EN
READ !!,"Press RETURN to CONTINUE: ",X:DTIME
+1 QUIT
LANGUAGE ; Get language data *///*
+1 SET DGLANGDT=9999999
SET (DGPRFLAN,DGLANG0)=""
+2 SET DGLANGDT=$ORDER(^DPT(DFN,.207,"B",DGLANGDT),-1)
+3 IF DGLANGDT=""
GOTO L1
+4 SET DGLANGDA=$ORDER(^DPT(DFN,.207,"B",DGLANGDT,0))
+5 SET DGLANG0=$GET(^DPT(DFN,.207,DGLANGDA,0))
SET Y=$PIECE(DGLANG0,U)
SET DGPRFLAN=$PIECE(DGLANG0,U,2)
+6 SET Y=DGLANGDT
XECUTE ^DD("DD")
SET DGLANGDT=Y
L1 WRITE !!,"Language Date/Time: ",$SELECT(DGLANGDT="":"UNANSWERED",1:DGLANGDT),!
+1 WRITE ?1,"Preferred Language: ",$SELECT(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN)
+2 KILL DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
+3 QUIT
SOGI ;**1059 SOGI FIELDS TO BE DISPLAYED VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121
+1 ;**1071 VAMPI-13755 (jfw) - Display Additional SO Info
+2 NEW EN,SXO,PRN
+3 WRITE !,"Birth Sex : ",$$GET1^DIQ(2,DFN,".02","E")
+4 ;SEXUAL ORIENTATION
+5 WRITE !,"Sexual Orientation: "
+6 SET EN=0
FOR
SET EN=$ORDER(^DPT(DFN,.025,EN))
if 'EN
QUIT
IF $PIECE($GET(^(EN,0)),"^",2)="A"
Begin DoDot:1
+7 NEW DGSOI
DO GETS^DIQ(2.025,EN_","_DFN,"*",,"DGSOI")
+8 WRITE !?20,DGSOI(2.025,EN_","_DFN_",",.01)_" ("_DGSOI(2.025,EN_","_DFN_",",.02)_")"
+9 WRITE !?25,"Date Created:",?44,DGSOI(2.025,EN_","_DFN_",",.03)
+10 WRITE !?25,"Date Last Updated: "_DGSOI(2.025,EN_","_DFN_",",.04)
End DoDot:1
+11 WRITE !,"Sexual Orientation Description: ",$$GET1^DIQ(2,DFN,".0251","E")
+12 WRITE !,"Pronoun: "
+13 SET EN=0
FOR
SET EN=$ORDER(^DPT(DFN,.2406,EN))
if 'EN
QUIT
Begin DoDot:1
+14 SET PRN=$GET(^DPT(DFN,.2406,EN,0))
+15 WRITE !?20,$PIECE($GET(^DG(47.78,PRN,0)),"^")
End DoDot:1
+16 WRITE !,"Pronoun Description: ",$$GET1^DIQ(2,DFN,".24061","E")
+17 WRITE !,"Self-Identified Gender Identity: ",$$GET1^DIQ(2,DFN,".024","E")
+18 QUIT
