- DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM,HM,BDB,ARF,RN,JAM - PATIENT INQUIRY (NEW) ; 04/01/2024@12:01
- ;;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,1104**;Aug 13, 1993;Build 59
- ; *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
- ; Reference to $$DISPLAY^PXCOMPACT in ICR #7327
- ;
- 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*1104 Look up COMPACT Act administrative eligibility
- W !,?1,"COMPACT Act Status: "_$$ELIG^DGCOMPACTELIG(DFN,"DGRPD")
- ;
- ;check for COMPACT Act information
- N DISPLAY
- S DISPLAY=$$DISPLAY^PXCOMPACT(DFN)
- ;DISPLAY will contain one of the following groups of information:
- ; If end date exists (episode has ended) and there are no extensions,
- ; "COMPACT Act Start Date"^EPISODE START DATE^"End Date"^EPISODE END DATE^"IP Benefit End Date"^INPATIENT BENEFIT END DATE^"OP Benefit end date"^OUTPATIENT BENEFIT END DATE
- ; If end date exists (episode has ended) and an extension exists,
- ; "Extension Start Date"^EXTENSION START DATE^"Episode End Date"^EPISODE END DATE
- ; If end date does not exist (episode is ongoing) and there are no extensions,
- ; For an inpatient with an INPATIENT BENEFIT END DATE,
- ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS^"Inpatient Benefit End Date"^INPATIENT BENEFIT END DATE
- ; Otherwise,
- ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS
- ; If end date does not exist (episode is ongoing) and an extension exists,
- ; "Extension Start Date"^EXTENSION START DATE^"Remaining Days"^EXTENSION REMAINING DAYS
- ;
- I $P(DISPLAY,U,3)["End Date" W !!,?6,"Episode End Date: ",$P(DISPLAY,U,4)
- E D
- . I $G(DISPLAY)="" W !! Q
- . I $P(DISPLAY,U)="COMPACT Act Start Date" W !,?4,"Episode Start Date: ",$P(DISPLAY,U,2)
- . I $P(DISPLAY,U)="Extension Start Date" W !,?7,"Ext. Start Date: ",$P(DISPLAY,U,2)
- . W ?38,"Residential Remaining Days: ",$P(DISPLAY,U,4),!
- ;
- ;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 Free Text: ",$$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 16235 printed Jan 18, 2025@03:56:50 Page 2
- DGRPD ;ALB/MRL,MLR,JAN,LBD,EG,BRM,JRC,BAJ,JAM,HM,BDB,ARF,RN,JAM - PATIENT INQUIRY (NEW) ; 04/01/2024@12:01
- +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,1104**;Aug 13, 1993;Build 59
- +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
- +18 ; Reference to $$DISPLAY^PXCOMPACT in ICR #7327
- +19 ;
- 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*1104 Look up COMPACT Act administrative eligibility
- +115 WRITE !,?1,"COMPACT Act Status: "_$$ELIG^DGCOMPACTELIG(DFN,"DGRPD")
- +116 ;
- +117 ;check for COMPACT Act information
- +118 NEW DISPLAY
- +119 SET DISPLAY=$$DISPLAY^PXCOMPACT(DFN)
- +120 ;DISPLAY will contain one of the following groups of information:
- +121 ; If end date exists (episode has ended) and there are no extensions,
- +122 ; "COMPACT Act Start Date"^EPISODE START DATE^"End Date"^EPISODE END DATE^"IP Benefit End Date"^INPATIENT BENEFIT END DATE^"OP Benefit end date"^OUTPATIENT BENEFIT END DATE
- +123 ; If end date exists (episode has ended) and an extension exists,
- +124 ; "Extension Start Date"^EXTENSION START DATE^"Episode End Date"^EPISODE END DATE
- +125 ; If end date does not exist (episode is ongoing) and there are no extensions,
- +126 ; For an inpatient with an INPATIENT BENEFIT END DATE,
- +127 ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS^"Inpatient Benefit End Date"^INPATIENT BENEFIT END DATE
- +128 ; Otherwise,
- +129 ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS
- +130 ; If end date does not exist (episode is ongoing) and an extension exists,
- +131 ; "Extension Start Date"^EXTENSION START DATE^"Remaining Days"^EXTENSION REMAINING DAYS
- +132 ;
- +133 IF $PIECE(DISPLAY,U,3)["End Date"
- WRITE !!,?6,"Episode End Date: ",$PIECE(DISPLAY,U,4)
- +134 IF '$TEST
- Begin DoDot:1
- +135 IF $GET(DISPLAY)=""
- WRITE !!
- QUIT
- +136 IF $PIECE(DISPLAY,U)="COMPACT Act Start Date"
- WRITE !,?4,"Episode Start Date: ",$PIECE(DISPLAY,U,2)
- +137 IF $PIECE(DISPLAY,U)="Extension Start Date"
- WRITE !,?7,"Ext. Start Date: ",$PIECE(DISPLAY,U,2)
- +138 WRITE ?38,"Residential Remaining Days: ",$PIECE(DISPLAY,U,4),!
- End DoDot:1
- +139 ;
- +140 ;display primary eligibility
- +141 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)
- +142 WRITE !,"Other Eligibilities: "
- +143 SET I=""
- SET X=""
- +144 FOR
- SET I=$ORDER(^DPT("AEL",DFN,I))
- if I=""
- QUIT
- Begin DoDot:1
- +145 IF $DATA(^DIC(8,I,0))
- IF I'=+X1
- SET X=$PIECE(^DIC(8,I,0),"^",1)_", "
- +146 IF $ORDER(^DPT("AEL",DFN,I))=""
- SET X=$EXTRACT(X,1,$LENGTH(X)-2)
- +147 if $X+$LENGTH(X)>79
- WRITE !?21
- WRITE X
- +148 QUIT
- End DoDot:1
- +149 IF '$$OKLINE^DGRPD1(16)
- GOTO Q
- +150 ;employability status
- +151 WRITE !?6,"Unemployable: ",$SELECT($PIECE(DGRP(.3),U,5)="Y":"YES",1:"NO")
- +152 IF '$$OKLINE^DGRPD1(19)
- GOTO Q
- +153 ; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status
- +154 WRITE !?6,"Permanent & Total Disabled: ",$SELECT($PIECE(DGRP(.3),U,4)="Y":"YES",1:"NO")
- +155 IF '$$OKLINE^DGRPD1(19)
- GOTO Q
- +156 ;display the catastrophic disability review date if there is one
- +157 DO CATDIS^DGRPD1
- +158 IF $GET(DGPRFLG)=1
- if '$$OKLINE^DGRPD1(19)
- GOTO Q
- Begin DoDot:1
- +159 NEW DGPDT,DGPTM
- +160 WRITE !,$$REPEAT^XLFSTR("-",78)
- +161 SET DGPDT=""
- SET DGPDT=$ORDER(^DGS(41.41,"ADC",DFN,DGPDT),-1)
- +162 WRITE !,"[PRE-REGISTER DATE:] "_$SELECT(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
- +163 SET DGPTM=$$PCTEAM^DGSDUTL(DFN)
- +164 IF $PIECE(DGPTM,U,2)]""
- WRITE !,"[PRIMARY CARE TEAM:] "_$PIECE(DGPTM,U,2)
- +165 WRITE !,$$REPEAT^XLFSTR("-",78)
- End DoDot:1
- +166 ;jam; DG*5.3*1064
- +167 IF $$INDSTATUS^DGENELA2(DFN)
- WRITE !,$$EZBLD^DIALOG(261133)
- +168 ;
- +169 ; Check if patient is an inpatient and on a DOM ward
- +170 ; If inpatient is on a DOM ward, don't display MT or CP messages
- +171 ; If inpatient is NOT on a DOM ward, don't display CP message
- +172 NEW DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
- +173 if '$$OKLINE^DGRPD1(16)
- GOTO Q
- +174 DO DOM^DGMTR
- +175 IF '$GET(DGDOM)
- Begin DoDot:1
- +176 DO DIS^DGMTU(DFN)
- +177 DO IN5^VADPT
- +178 IF $GET(VAIP(1))=""
- DO DISP^IBARXEU(DFN,DT,3,1)
- End DoDot:1
- +179 ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
- +180 ;Added for LTC III (DG*5.3*518)
- DO DIS^EASECU(DFN)
- +181 SET VAIP("L")=""
- +182 IF $$OKLINE^DGRPD1(14)
- DO INP
- +183 ;*KNR*
- IF '$GET(DGRPOUT)
- IF ($$OKLINE^DGRPD1(10))
- DO SA
- +184 ;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 Free Text: ",$$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