Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGRPD

DGRPD.m

Go to the documentation of this file.
  1. 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
  1. ; *286* Newing variables X,Y in OKLINE subroutine
  1. ; *358* If a patient is on a domiciliary ward, don't display MEANS
  1. ; TEST required/Medication Copayment Exemption messages
  1. ; *436* If an inpatient is not on a domiciliary ward, don't display
  1. ; Medication Copayment Exemption message
  1. ; *545* Add death information near the remarks field
  1. ; *677* Added Emergency Response
  1. ; *688* Modified to display Country and Foreign Address
  1. ; *936* Modified to display Health Benefit Plans
  1. ; *940* #879316,#879318 - Display Permanent & Total Disabled Status
  1. ; *941* #887088 - Redesign of Inquiry Screen layout for displaying the addresses
  1. ;
  1. ; Integration Agreements:
  1. ; 6138 - DGHBPUTL API
  1. ;
  1. ; Reference to DIS^EASECU in ICR #6771
  1. ; Reference to $$DISPLAY^PXCOMPACT in ICR #7327
  1. ;
  1. 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
  1. EN ;call to display patient inquiry - input DFN
  1. ;MPI/PD CHANGE
  1. S DGCMOR="UNSPECIFIED",DGMPI=$G(^DPT(+DFN,"MPI"))
  1. K DGRPOUT,DGHOW S DGABBRV=$S($D(^DG(43,1,0)):+$P(^(0),"^",38),1:0),DGRPU="UNSPECIFIED" D DEM^VADPT,HDR^DGRPD1
  1. ;JAM begin changes Patch DG*5.3*941 add .115 and new address fields layout
  1. F I=0,.11,.13,.121,.122,.31,.32,.36,.361,.141,.3,.115 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
  1. ;jam DG*5.3*925 RM#788099 change labels to "Permanent Mailing Address" and "Temporary Mailing Address"
  1. ;
  1. W " Residential Address: "
  1. W ?40,"Mailing Address: " ;DG*5.3*1056 remove Permanent from the address label
  1. S DGAD=.115,(DGA1,DGA2)=1 D AL^DGRPU(35) S DGAD=.11,DGA1=1,DGA2=2 D AL^DGRPU(35)
  1. W !?5
  1. N Z,Z1
  1. 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")
  1. ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
  1. 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)
  1. N DGCC
  1. S DGCC=$$COUNTY^DGRPCADD(.DGRP,.115) ; print County if applicable
  1. W !?5,"County: "_DGCC
  1. S DGCC=$$COUNTY^DGRPCADD(.DGRP,.11) ; print County if applicable
  1. W ?44,"County: "_DGCC
  1. W !?6,"Phone: ",$S($P(DGRP(.13),U,1)]"":$P(DGRP(.13),U,1),1:DGRPU)
  1. W ?42,"Bad Addr: ",$$EXTERNAL^DILFD(2,.121,"",$P(DGRP(.11),U,16))
  1. W !?5,"Office: ",$S($P(DGRP(.13),U,2)]"":$P(DGRP(.13),U,2),1:DGRPU)
  1. W ?46,"Cell: ",$S($P(DGRP(.13),U,4)]"":$P(DGRP(.13),U,4),1:DGRPU)
  1. W !?44,"E-mail: ",$S($P(DGRP(.13),U,3)]"":$P(DGRP(.13),U,3),1:DGRPU)
  1. W !!
  1. K DGA,DGA1,DGA2
  1. I $P(DGRP(.121),"^",9)="Y" S DGAD=.121,(DGA1,DGA2)=1 D AL^DGRPU(30)
  1. N CONACT
  1. ; set Confidential Active Flag
  1. S CONACT=$P(DGRP(.141),"^",9)
  1. I CONACT="Y" D
  1. .; check the begin/end dates, set active flag to NO and do not display if outside the date range
  1. .N DGCABEG,DGCAEND,DGI
  1. .S DGCABEG=$P(DGRP(.141),U,7),DGCAEND=$P(DGRP(.141),U,8)
  1. .I 'DGCABEG!(DGCABEG>DT)!(DGCAEND&(DGCAEND<DT)) S CONACT="N" Q
  1. .S DGAD=.141,DGA1=1,DGA2=2 D AL^DGRPU(30)
  1. W " Temporary Mailing Address: "
  1. W ?40,"Confidential Mailing Address: "
  1. W !?5
  1. W $S($D(DGA(1)):DGA(1),1:"NO TEMPORARY MAILING ADDRESS") W ?44,$S($D(DGA(2)):DGA(2),1:"NONE ON FILE")
  1. ; loop through DGA array beginning with DGA(2) and print data at ?5 (odds) and ?44 (evens)
  1. 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)
  1. W !
  1. I $D(DGA(1)) D
  1. .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.121) ; print County if applicable
  1. .W ?5,"County: "_DGCC
  1. I $D(DGA(2)) D
  1. .S DGCC=$$COUNTY^DGRPCADD(.DGRP,.141) ; print County if applicable
  1. .W ?44,"County: "_DGCC
  1. ;W !?2,"CASS Cert: "_$S($P(DGRP(.121),U,15)="Y":"Certified",$P(DGRP(.121),U,15)="F":"Failed",1:"NC")
  1. ;W ?41,"CASS Cert: "_$S($P(DGRP(.141),U,17)="Y":"Certified",$P(DGRP(.141),U,17)="F":"Failed",1:"NC")
  1. W !?6,"Phone: ",$S($P(DGRP(.121),U,9)'="Y":"NOT APPLICABLE",$P(DGRP(.121),U,10)]"":$P(DGRP(.121),U,10),1:DGRPU)
  1. 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)
  1. S X="NOT APPLICABLE"
  1. I $P(DGRP(.121),U,9)="Y" D
  1. .S Y=$P(DGRP(.121),U,7) X:Y]"" ^DD("DD")
  1. .S X=$S(Y]"":Y,1:DGRPU)_"-",Y=$P(DGRP(.121),U,8) X:Y]"" ^DD("DD")
  1. .S X=X_$S(Y]"":Y,1:DGRPU)
  1. N DGACT,DGTYP,DGCAN,DGBEG,DGEND,DGZ,DGXX,DGX,DGTYPNAM,DGCAT
  1. W !?2,"From/To: ",X
  1. S DGX="NOT APPLICABLE"
  1. I CONACT="Y" D
  1. .S (DGZ,DGX)="" F DGI=7,8 S DGZ=$P(DGRP(.141),"^",DGI),Y=DGZ D
  1. ..I DGI=7 X:Y]"" ^DD("DD") S DGBEG=Y,DGX=Y
  1. ..I DGI=8 X:Y]"" ^DD("DD") S DGEND=Y,DGX=DGX_"-"_$S(Y]"":Y,1:"UNANSWERED")
  1. W ?43,"From/To: "_DGX
  1. W !?41,"Confidential Address Categories: " I $D(^DPT(DFN,.14)) D
  1. .; If not active, do not display categories
  1. .I CONACT'="Y" Q
  1. .S DGCAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
  1. .S DGX="",DGCAN="" F S DGCAN=$O(^DPT(DFN,.14,DGCAN)) Q:DGCAN="" D
  1. ..Q:'$D(^DPT(DFN,.14,DGCAN,0))
  1. ..S DGTYP=$P(^DPT(DFN,.14,DGCAN,0),"^",1),DGACT=$P(^DPT(DFN,.14,DGCAN,0),"^",2)
  1. ..S DGACT=$S(DGACT="Y":"Active",DGACT="N":"Inactive",1:"Unanswered")
  1. ..S DGTYPNAM="" F DGI=1:1 S DGTYPNAM=$P(DGCAT,";",DGI) Q:DGTYPNAM="" D
  1. ...I DGTYPNAM[DGTYP S DGTYPNAM=$P(DGTYPNAM,":",2),DGX=DGTYPNAM_"("_DGACT_")"_","_DGX
  1. S DGXX="" F DGI=1:1 S DGXX=$P(DGX,",",DGI) Q:DGXX="" D
  1. .W !?42,DGXX
  1. ;
  1. I '$$OKLINE^DGRPD1(16) G Q
  1. N DGEMER S DGEMER=$$EXTERNAL^DILFD(2,.181,"",$P($G(^DPT(DFN,.18)),"^"))
  1. W:DGEMER]"" !?32,"Emergency Response: ",DGEMER
  1. 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")
  1. 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
  1. ;**159 REMOVE CONDITIONAL DISPLAY OF BIRTH SEX AND GROUP WITH OTHER SOGI FIELDS
  1. I 'DGABBRV W ! D
  1. .N RACE,ETHNIC,PTR,VAL,X,DIWL,DIWR,DIWF
  1. .K ^UTILITY($J,"W")
  1. .S PTR=0 F S PTR=+$O(^DPT(DFN,.02,PTR)) Q:'PTR D
  1. ..S VAL=+$G(^DPT(DFN,.02,PTR,0))
  1. ..Q:$$INACTIVE^DGUTL4(VAL,1)
  1. ..S VAL=$$PTR2TEXT^DGUTL4(VAL,1) S:+$O(^DPT(DFN,.02,PTR)) VAL=VAL_", "
  1. ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
  1. .M RACE=^UTILITY($J,"W",0) S:$G(RACE(1,0))="" RACE(1,0)="UNANSWERED"
  1. .K ^UTILITY($J,"W")
  1. .S PTR=0 F S PTR=+$O(^DPT(DFN,.06,PTR)) Q:'PTR D
  1. ..S VAL=+$G(^DPT(DFN,.06,PTR,0))
  1. ..Q:$$INACTIVE^DGUTL4(VAL,2)
  1. ..S VAL=$$PTR2TEXT^DGUTL4(VAL,2) S:+$O(^DPT(DFN,.06,PTR)) VAL=VAL_", "
  1. ..S X=VAL,DIWL=0,DIWR=30,DIWF="" D ^DIWP
  1. .M ETHNIC=^UTILITY($J,"W",0) S:$G(ETHNIC(1,0))="" ETHNIC(1,0)="UNANSWERED"
  1. .K ^UTILITY($J,"W")
  1. .W ?3,"Race: ",RACE(1,0),?40,"Ethnicity: ",ETHNIC(1,0)
  1. .F X=2:1 Q:'$D(RACE(X,0))&'$D(ETHNIC(X,0)) W !,?9,$G(RACE(X,0)),?51,$G(ETHNIC(X,0))
  1. I '$$OKLINE^DGRPD1(16) G Q
  1. ;**1059 ADDING SOGI fields including BIRTH SEX
  1. D SOGI
  1. D LANGUAGE
  1. I '$$OKLINE^DGRPD1(10) G Q
  1. ;display cv status #4156
  1. N DGCV S DGCV=$$CVEDT^DGCV(+DFN)
  1. 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")
  1. ;DG*5.3*1104 Look up COMPACT Act administrative eligibility
  1. W !,?1,"COMPACT Act Status: "_$$ELIG^DGCOMPACTELIG(DFN,"DGRPD")
  1. ;
  1. ;check for COMPACT Act information
  1. N DISPLAY
  1. S DISPLAY=$$DISPLAY^PXCOMPACT(DFN)
  1. ;DISPLAY will contain one of the following groups of information:
  1. ; If end date exists (episode has ended) and there are no extensions,
  1. ; "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
  1. ; If end date exists (episode has ended) and an extension exists,
  1. ; "Extension Start Date"^EXTENSION START DATE^"Episode End Date"^EPISODE END DATE
  1. ; If end date does not exist (episode is ongoing) and there are no extensions,
  1. ; For an inpatient with an INPATIENT BENEFIT END DATE,
  1. ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS^"Inpatient Benefit End Date"^INPATIENT BENEFIT END DATE
  1. ; Otherwise,
  1. ; "COMPACT Act Start Date"^EPISODE START DATE^"Remaining Days"^REMAINING INPATIENT DAYS or REMAINING OUTPATIENT DAYS
  1. ; If end date does not exist (episode is ongoing) and an extension exists,
  1. ; "Extension Start Date"^EXTENSION START DATE^"Remaining Days"^EXTENSION REMAINING DAYS
  1. ;
  1. I $P(DISPLAY,U,3)["End Date" W !!,?6,"Episode End Date: ",$P(DISPLAY,U,4)
  1. E D
  1. . I $G(DISPLAY)="" W !! Q
  1. . I $P(DISPLAY,U)="COMPACT Act Start Date" W !,?4,"Episode Start Date: ",$P(DISPLAY,U,2)
  1. . I $P(DISPLAY,U)="Extension Start Date" W !,?7,"Ext. Start Date: ",$P(DISPLAY,U,2)
  1. . W ?38,"Residential Remaining Days: ",$P(DISPLAY,U,4),!
  1. ;
  1. ;display primary eligibility
  1. 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)
  1. W !,"Other Eligibilities: "
  1. S I="",X=""
  1. F S I=$O(^DPT("AEL",DFN,I)) Q:I="" D
  1. . I $D(^DIC(8,I,0)),I'=+X1 S X=$P(^DIC(8,I,0),"^",1)_", "
  1. . I $O(^DPT("AEL",DFN,I))="" S X=$E(X,1,$L(X)-2)
  1. . W:$X+$L(X)>79 !?21 W X
  1. . Q
  1. I '$$OKLINE^DGRPD1(16) G Q
  1. ;employability status
  1. W !?6,"Unemployable: ",$S($P(DGRP(.3),U,5)="Y":"YES",1:"NO")
  1. I '$$OKLINE^DGRPD1(19) G Q
  1. ; KUM DG*5.3*940 RM #879316,#879318 - Display Permanent & Total Disabled status
  1. W !?6,"Permanent & Total Disabled: ",$S($P(DGRP(.3),U,4)="Y":"YES",1:"NO")
  1. I '$$OKLINE^DGRPD1(19) G Q
  1. ;display the catastrophic disability review date if there is one
  1. D CATDIS^DGRPD1
  1. I $G(DGPRFLG)=1 G Q:'$$OKLINE^DGRPD1(19) D
  1. . N DGPDT,DGPTM
  1. . W !,$$REPEAT^XLFSTR("-",78)
  1. . S DGPDT="",DGPDT=$O(^DGS(41.41,"ADC",DFN,DGPDT),-1)
  1. . W !,"[PRE-REGISTER DATE:] "_$S(DGPDT]"":$$FMTE^XLFDT(DGPDT,"1D"),1:"NONE ON FILE")
  1. . S DGPTM=$$PCTEAM^DGSDUTL(DFN)
  1. . I $P(DGPTM,U,2)]"" W !,"[PRIMARY CARE TEAM:] "_$P(DGPTM,U,2)
  1. . W !,$$REPEAT^XLFSTR("-",78)
  1. ;jam; DG*5.3*1064
  1. I $$INDSTATUS^DGENELA2(DFN) W !,$$EZBLD^DIALOG(261133)
  1. ;
  1. ; Check if patient is an inpatient and on a DOM ward
  1. ; If inpatient is on a DOM ward, don't display MT or CP messages
  1. ; If inpatient is NOT on a DOM ward, don't display CP message
  1. N DGDOM,DGDOM1,VAHOW,VAROOT,VAINDT,VAIP,VAERR
  1. G Q:'$$OKLINE^DGRPD1(16)
  1. D DOM^DGMTR
  1. I '$G(DGDOM) D
  1. .D DIS^DGMTU(DFN)
  1. .D IN5^VADPT
  1. .I $G(VAIP(1))="" D DISP^IBARXEU(DFN,DT,3,1)
  1. ;I 'DGABBRV,$E(IOST,1,2)="C-" F I=$Y:1:20 W !
  1. D DIS^EASECU(DFN) ;Added for LTC III (DG*5.3*518)
  1. S VAIP("L")=""
  1. I $$OKLINE^DGRPD1(14) D INP
  1. I '$G(DGRPOUT),($$OKLINE^DGRPD1(10)) D SA ;*KNR*
  1. ;MPI/PD CHANGE
  1. 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
  1. ;
  1. INP S VAIP("D")="L" D INP^DGPMV10
  1. S DGPMT=0
  1. D CS^DGPMV10 K DGPMT,DGPMIFN K:'$D(DGSWITCH) DGPMVI,DGPMDCD Q
  1. 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)
  1. Q
  1. SAA ;Scheduled Admit Data
  1. W !!?14,"Scheduled Admit"
  1. W:$D(^DIC(42,+$P(X,U,8),0)) " on ward "_$P(^(0),U)
  1. W:$D(^DIC(45.7,+$P(X,U,9),0)) " for treating specialty "_$P(^(0),U)
  1. W " on "_$$FMTE^XLFDT(L,"5DZ")
  1. Q ;SAA
  1. ;
  1. 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:"")
  1. ;
  1. FA ;
  1. N DGARRAY,SDCNT
  1. S DGARRAY("FLDS")="1;2;3;18",DGARRAY(4)=DFN,DGARRAY(1)=DT,DGARRAY("SORT")="P"
  1. S SDCNT=$$SDAPI^SDAMA301(.DGARRAY),CT=0 W !!,"Future Appointments: "
  1. ;if there is lower subscripts hanging from the 101 node,
  1. ;then it is a valid appointment, otherwise it is
  1. ;an error eg 01/20/2005
  1. ;G:'$$OKLINE^DGRPD1(13) RMK ;*///*
  1. I $D(^TMP($J,"SDAMA301",101))=1 W "Appointment Database is Unavailable" G RMK
  1. I $O(^TMP($J,"SDAMA301",DFN,DT))'>0 W "NONE" G RMK
  1. ;
  1. W ?22,"Date",?33,"Time",?39,"Clinic",!?22 F I=22:1:75 W "="
  1. F FA=DT:0 S FA=$O(^TMP($J,"SDAMA301",DFN,FA)) G RMK:'FA D Q:CT>5
  1. .N STAT S STAT=$P($P(^TMP($J,"SDAMA301",DFN,FA),U,3),";")
  1. .S C=+$P(^TMP($J,"SDAMA301",DFN,FA),U,2) I STAT'["C" D
  1. ..D COV
  1. ..N DGAPPT S DGAPPT=$$FMTE^XLFDT($E(FA,1,12),"5Z")
  1. ..W !?22,$P(DGAPPT,"@"),?33,$P(DGAPPT,"@",2)
  1. ..W ?39,$P($P(^TMP($J,"SDAMA301",DFN,FA),U,2),";",2)," ",COV
  1. ..Q
  1. I $O(^TMP($J,"SDAMA301",DFN,FA))>0 W !,"See Scheduling options for additional appointments."
  1. RMK I '$G(DGRPOUT),($$OKLINE^DGRPD1(15)) W !!,"Remarks: ",$P(^DPT(DFN,0),"^",10) ;*///*
  1. D GETS^DIQ(2,DFN_",",".351;.353;.354;.355","E","PDTHINFO")
  1. W !!
  1. W "Date of Death Information"
  1. W !,?5,"Date of Death: ",$G(PDTHINFO(2,DFN_",",.351,"E"))
  1. W !,?5,"Source of Notification: ",$G(PDTHINFO(2,DFN_",",.353,"E"))
  1. W !,?5,"Updated Date/Time: ",$G(PDTHINFO(2,DFN_",",.354,"E"))
  1. W !,?5,"Last Edited By: ",$G(PDTHINFO(2,DFN_",",.355,"E")),!
  1. I $$OKLINE^DGRPD1(14) D EC^DGRPD1
  1. ; KUM DG*5.3*936 Call tag to display Health Benefit Plans assigned to Veteran
  1. D HBP
  1. K DGARRAY,SDCNT,^TMP($J,"SDAMA301"),ADM,L,TRN,DIS,SSN,FA,C,COV,NOW,CT,DGD,DGD1,I ;Y killed after dghinqky
  1. Q
  1. ; KUM DG*5.3*936 Display Health Benefit Plans assigned to Veteran
  1. HBP ;W !!,"Veteran Medical Benefit Plan Currently Assigned to Veteran:" ;DG*5.3*987 HM
  1. W !!,"VHA Profiles Currently Assigned to Veteran:" ;DG*5.3*1006 BDB;DG*5.3*987 HM
  1. N DGHBP,HBP,DGCOUNT,DGHBIEN,DGPNAME,X,DGCNT,DGLN,DGLINE
  1. S DGCOUNT=0
  1. D GETHBP^DGHBPUTL(DFN)
  1. S DGHBP="" F S DGHBP=$O(HBP("CUR",DGHBP)) Q:DGHBP="" D
  1. .; DG*5.3*987; jam; Place "zz" before the plan name for inactive plans
  1. .S DGHBIEN=+HBP("CUR",DGHBP)
  1. .I $P($G(^DGHBP(25.11,DGHBIEN,0)),"^",4)="Y" S DGPNAME="zz "_DGHBP
  1. .E S DGPNAME=DGHBP
  1. .; DG*5.3*987; arf; Add word wrapping for plan names
  1. .S X=DGPNAME
  1. .K ^UTILITY($J,"W") S DIWL=0,DIWR=70,DIWF="" D ^DIWP
  1. .S DGCNT=^UTILITY($J,"W",0)
  1. .F DGLN=1:1:DGCNT S DGLINE=^UTILITY($J,"W",0,DGLN,0) W !,?3,DGLINE
  1. .K ^UTILITY($J,"W")
  1. .S DGCOUNT=DGCOUNT+1
  1. I DGCOUNT=0 W !,?3,"None"
  1. Q
  1. ;
  1. COV S COV=$S(+$P(^TMP($J,"SDAMA301",DFN,FA),U,18)=7:" (Collateral) ",1:"")
  1. S COV=COV_$S(STAT["NT":" * NO ACTION TAKEN *",STAT["N":" * NO-SHOW *",1:""),CT=CT+1 Q
  1. Q
  1. ;
  1. OREN S XQORQUIT=1 Q:'$D(ORVP) S DFN=+ORVP D EN R !!,"Press RETURN to CONTINUE: ",X:DTIME
  1. Q
  1. LANGUAGE ; Get language data *///*
  1. S DGLANGDT=9999999,(DGPRFLAN,DGLANG0)=""
  1. S DGLANGDT=$O(^DPT(DFN,.207,"B",DGLANGDT),-1)
  1. I DGLANGDT="" G L1
  1. S DGLANGDA=$O(^DPT(DFN,.207,"B",DGLANGDT,0))
  1. S DGLANG0=$G(^DPT(DFN,.207,DGLANGDA,0)),Y=$P(DGLANG0,U),DGPRFLAN=$P(DGLANG0,U,2)
  1. S Y=DGLANGDT X ^DD("DD") S DGLANGDT=Y
  1. L1 W !!,"Language Date/Time: ",$S(DGLANGDT="":"UNANSWERED",1:DGLANGDT),!
  1. W ?1,"Preferred Language: ",$S(DGPRFLAN="":"UNANSWERED",1:DGPRFLAN)
  1. K DGLANGDT,DGPRFLAN,DGLANG0,DGLANGDA
  1. Q
  1. SOGI ;**1059 SOGI FIELDS TO BE DISPLAYED VAMPI-11114,VAMPI-11118,VAMPI-11120, VAMPI-11121
  1. ;**1071 VAMPI-13755 (jfw) - Display Additional SO Info
  1. N EN,SXO,PRN
  1. W !,"Birth Sex : ",$$GET1^DIQ(2,DFN,".02","E")
  1. ;SEXUAL ORIENTATION
  1. W !,"Sexual Orientation: "
  1. S EN=0 F S EN=$O(^DPT(DFN,.025,EN)) Q:'EN I $P($G(^(EN,0)),"^",2)="A" D
  1. .N DGSOI D GETS^DIQ(2.025,EN_","_DFN,"*",,"DGSOI")
  1. .W !?20,DGSOI(2.025,EN_","_DFN_",",.01)_" ("_DGSOI(2.025,EN_","_DFN_",",.02)_")"
  1. .W !?25,"Date Created:",?44,DGSOI(2.025,EN_","_DFN_",",.03)
  1. .W !?25,"Date Last Updated: "_DGSOI(2.025,EN_","_DFN_",",.04)
  1. W !,"Sexual Orientation Free Text: ",$$GET1^DIQ(2,DFN,".0251","E")
  1. W !,"Pronoun: "
  1. S EN=0 F S EN=$O(^DPT(DFN,.2406,EN)) Q:'EN D
  1. .S PRN=$G(^DPT(DFN,.2406,EN,0))
  1. .W !?20,$P($G(^DG(47.78,PRN,0)),"^")
  1. W !,"Pronoun Description: ",$$GET1^DIQ(2,DFN,".24061","E")
  1. W !,"Self-Identified Gender Identity: ",$$GET1^DIQ(2,DFN,".024","E")
  1. Q