PSODEM ;BIR/SAB - PATIENT DEMOGRAPHICS ;Jan 21, 2021@16:15
;;7.0;OUTPATIENT PHARMACY;**5,19,233,258,326,390,411,402,500,452,556,622**;DEC 1997;Build 44
;External reference to ^GMRADPT supported by DBIA 10099
;External reference to ^DIC(31 supported by DBIA 658
;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
;
;RTW BEGIN PATIENT DEMOGRAPHIC CHANGE INFORMATION---------------------------
;EPIP NSR20151001 PATIENT DEMOGRAPHICS and Clinical Alerts added
;output, which will appear right after the Pharmacy Narrative:
; * Primary Care Team and their office Phone
; * PC Provider and Position
; * PC Provider's pager and office phone number
; * Current facility (or institution) of the Patient based on PC Team or appointment & visit history}
; * Patient file REMARKS
; * Clinical Alerts (for example, when a patient part of a researh study)
; * then pause the screen until the user pressed the <ENTER> key
;RTW END PATIENT DEMOGRAPHIC CHANGE INFORMATION---------------------------
GET S DFN=DA D 6^VADPT,PID^VADPT U IO W @IOF,!,VADM(1)
I +VAPA(9) W !?5,"(TEMP ADDRESS from "_$P(VAPA(9),"^",2)_" till "_$S($P(VAPA(10),"^",2)]"":$P(VAPA(10),"^",2),1:"(no end date)")_")"
W !,VAPA(1),?40,"DOB: ",$S(+VADM(3):$P(VADM(3),"^",2),1:"UNKNOWN") W:VAPA(2)]"" !,VAPA(2) W:VAPA(3)]"" !,VAPA(3)
W !,VAPA(4),?40,"PHONE: "_VAPA(8),!,$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),?40,"ELIG: "_$P(VAEL(1),"^",2) W:+VAEL(3) !?40,"SC%: "_$P(VAEL(3),"^",2)
I $D(^PS(55,DFN,0)) W:$P(^(0),"^",2) !,"CANNOT USE SAFETY CAPS." I +$P(^(0),"^",4) W ?40,"DIALYSIS PATIENT."
I $G(^PS(55,DFN,1))]"" S X=^(1) W !!?5,"Pharmacy Narrative: " F I=1:1 Q:$P(X," ",I,99)="" W:$X+$L($P(X," ",I))+$L(" ")>IOM ! W $P(X," ",I)," "
RE ;
D DEMOG^PSODEMSB(DFN) ;RTW PATIENT DEMOGRAPHIC CHANGE
S (WT,HT)="",X="GMRVUTL" X ^%ZOSF("TEST") I $T D
.F GMRVSTR="WT","HT" S VM=GMRVSTR D EN6^GMRVUTL S @VM=X,$P(@VM,"^")=$E($P(@VM,"^"),4,5)_"/"_$E($P(@VM,"^"),6,7)_"/"_($E($P(@VM,"^"),1,3)+1700)
.S X=$P(WT,"^",8),Y=$J(X/2.2046226,0,2),$P(WT,"^",9)=Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),$P(HT,"^",9)=Y
Q:$G(POERR)
W !!,"WEIGHT(Kg): " W:+$P(WT,"^",8) $P(WT,"^",9)_" ("_$P(WT,"^")_")" W ?41,"HEIGHT(cm): " W:$P(HT,"^",8) $P(HT,"^",9)_" ("_$P(HT,"^")_")" K VM,WT,HT
;
; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
CRCL S PSOBSA=$$BSA^PSSDSAPI(DFN),PSOBSA=$P(PSOBSA,"^",3),PSOBSA=$S(PSOBSA'>0:"_______",1:$J(PSOBSA,4,2))
S RSLT=$$CRCL^PSOORUT2(DFN)
; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
; Display format of CrCL and Creatinine results updated - PSO*7.0*556
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)<.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_" (CREAT: Not Found)"
I ($P($G(RSLT),"^",2)'["Not Found")&($P($G(RSLT),"^",3)>=.01) S ZDSPL=" CrCL: "_$P(RSLT,"^",2)_"(est.)"_" (CREAT: "_$P($G(RSLT),"^",3)_"mg/dL "_$P($G(RSLT),"^")_")"
W !,$G(ZDSPL),?40," BSA (m2): ",PSOBSA K PSOBSA,ZDSPL,RSLT
;
S PSLC=0 G MA:$P($G(^DPT(DFN,.17)),"^",2)'="I"
I '$D(VAEL(1)) D ELIG^VADPT W !!,"ELIGIBILITY: ",$P(VAEL(1),"^",2) W:+VAEL(3) ?$X+5,"SC%: "_$P(VAEL(3),"^",2) S PSLC=PSLC+2
MA K SC W !,"DISABILITIES: " S PSLC=PSLC+2
F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^DPT(DFN,.372,I,0)):^(0),1:"") D:+I1
.S PSDIS=$S($P($G(^DIC(31,+I1,0)),"^")]""&($P($G(^(0)),"^",4)']""):$P(^(0),"^"),$P($G(^DIC(31,+I1,0)),"^",4)]"":$P(^(0),"^",4),1:""),PSCNT=$P(I1,"^",2)
.X:($X+$L(PSDIS)+7)>(IOM-8) "W !?14 S PSLC=PSLC+1" W PSDIS,"-",PSCNT,"% (",$S($P(I1,"^",3):"SC",1:"NSC"),"), "
.I $E(IOST)="C",$Y+4>IOSL,$D(PSTYPE) K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT W @IOF,?13
X "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q" I $T D:'$D(PSOPTPST) GMRA
D WH
Q K SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS D:$G(PSTYPE)']"" KVA^VADPT Q
GMRA K ^TMP($J,"AL") S GMRA="0^0^111" D ^GMRADPT I GMRAL D
.F DR=0:0 S DR=$O(GMRAL(DR)) Q:'DR S ^TMP($J,"AL",$S('$P(GMRAL(DR),"^",5):1,1:2),$P(GMRAL(DR),"^",7),$P(GMRAL(DR),"^",2))=""
.W !!,"ALLERGIES: " S (DR,TY)="" F I=0:0 S TY=$O(^TMP($J,"AL",1,TY)) Q:TY="" F D=0:0 S DR=$O(^TMP($J,"AL",1,TY,DR)) Q:DR="" W:$X+$L(DR)+$L(", ")>IOM !?11 W DR_", " D
..I $E(IOST)="C",$Y+4>IOSL,$D(PSTYPE) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT W @IOF,?18
.W !!,"ADVERSE REACTIONS: " S (DR,TY)="" F I=0:0 S TY=$O(^TMP($J,"AL",2,TY)) Q:TY="" F D=0:0 S DR=$O(^TMP($J,"AL",2,TY,DR)) Q:DR="" W:$X+$L(DR)+$L(", ")>IOM !?19 W DR_", " D
..I $E(IOST)="C",$Y+4>IOSL,$D(PSTYPE) W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue" D ^DIR K DIR,DTOUT W @IOF,?18
I $G(GMRAL)']"" F AD="ALLERGIES:","ADVERSE REACTIONS:" W !!,AD I $G(PSOFROM)="" F ADL=1:1:IOM-($L(AD)+5) W "_"
I GMRAL=0 W !!,"ALLERGIES: NKA",!!,"ADVERSE REACTIONS:"
W ! K TY,D,I,GMRA,GMRAL,DR,AD,ADL,^TMP($J,"AL") Q
WH ; WOMEN'S HEALTH
I $P(VADM(5),U,1)="F" W !,"WOMEN'S HEALTH: ",$$GETSTATUS^WVRPCPT(DFN),!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSODEM 5265 printed Apr 09, 2024@21:33:08 Page 2
PSODEM ;BIR/SAB - PATIENT DEMOGRAPHICS ;Jan 21, 2021@16:15
+1 ;;7.0;OUTPATIENT PHARMACY;**5,19,233,258,326,390,411,402,500,452,556,622**;DEC 1997;Build 44
+2 ;External reference to ^GMRADPT supported by DBIA 10099
+3 ;External reference to ^DIC(31 supported by DBIA 658
+4 ;External reference to $$BSA^PSSDSAPI supported by DBIA 5425
+5 ;
+6 ;RTW BEGIN PATIENT DEMOGRAPHIC CHANGE INFORMATION---------------------------
+7 ;EPIP NSR20151001 PATIENT DEMOGRAPHICS and Clinical Alerts added
+8 ;output, which will appear right after the Pharmacy Narrative:
+9 ; * Primary Care Team and their office Phone
+10 ; * PC Provider and Position
+11 ; * PC Provider's pager and office phone number
+12 ; * Current facility (or institution) of the Patient based on PC Team or appointment & visit history}
+13 ; * Patient file REMARKS
+14 ; * Clinical Alerts (for example, when a patient part of a researh study)
+15 ; * then pause the screen until the user pressed the <ENTER> key
+16 ;RTW END PATIENT DEMOGRAPHIC CHANGE INFORMATION---------------------------
GET SET DFN=DA
DO 6^VADPT
DO PID^VADPT
USE IO
WRITE @IOF,!,VADM(1)
+1 IF +VAPA(9)
WRITE !?5,"(TEMP ADDRESS from "_$PIECE(VAPA(9),"^",2)_" till "_$SELECT($PIECE(VAPA(10),"^",2)]"":$PIECE(VAPA(10),"^",2),1:"(no end date)")_")"
+2 WRITE !,VAPA(1),?40,"DOB: ",$SELECT(+VADM(3):$PIECE(VADM(3),"^",2),1:"UNKNOWN")
if VAPA(2)]""
WRITE !,VAPA(2)
if VAPA(3)]""
WRITE !,VAPA(3)
+3 WRITE !,VAPA(4),?40,"PHONE: "_VAPA(8),!,$PIECE(VAPA(5),"^",2)_" "_$SELECT(VAPA(11)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6)),?40,"ELIG: "_$PIECE(VAEL(1),"^",2)
if +VAEL(3)
WRITE !?40,"SC%: "_$PIECE(VAEL(3),"^",2)
+4 IF $DATA(^PS(55,DFN,0))
if $PIECE(^(0),"^",2)
WRITE !,"CANNOT USE SAFETY CAPS."
IF +$PIECE(^(0),"^",4)
WRITE ?40,"DIALYSIS PATIENT."
+5 IF $GET(^PS(55,DFN,1))]""
SET X=^(1)
WRITE !!?5,"Pharmacy Narrative: "
FOR I=1:1
if $PIECE(X," ",I,99)=""
QUIT
if $X+$LENGTH($PIECE(X," ",I))+$LENGTH(" ")>IOM
WRITE !
WRITE $PIECE(X," ",I)," "
RE ;
+1 ;RTW PATIENT DEMOGRAPHIC CHANGE
DO DEMOG^PSODEMSB(DFN)
+2 SET (WT,HT)=""
SET X="GMRVUTL"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+3 FOR GMRVSTR="WT","HT"
SET VM=GMRVSTR
DO EN6^GMRVUTL
SET @VM=X
SET $PIECE(@VM,"^")=$EXTRACT($PIECE(@VM,"^"),4,5)_"/"_$EXTRACT($PIECE(@VM,"^"),6,7)_"/"_($EXTRACT($PIECE(@VM,"^"),1,3)+1700)
+4 SET X=$PIECE(WT,"^",8)
SET Y=$JUSTIFY(X/2.2046226,0,2)
SET $PIECE(WT,"^",9)=Y
SET X=$PIECE(HT,"^",8)
SET Y=$JUSTIFY(2.54*X,0,2)
SET $PIECE(HT,"^",9)=Y
End DoDot:1
+5 if $GET(POERR)
QUIT
+6 WRITE !!,"WEIGHT(Kg): "
if +$PIECE(WT,"^",8)
WRITE $PIECE(WT,"^",9)_" ("_$PIECE(WT,"^")_")"
WRITE ?41,"HEIGHT(cm): "
if $PIECE(HT,"^",8)
WRITE $PIECE(HT,"^",9)_" ("_$PIECE(HT,"^")_")"
KILL VM,WT,HT
+7 ;
+8 ; Display CrCl/BSA - show serum creatinine if CrCl can't be calculated
CRCL SET PSOBSA=$$BSA^PSSDSAPI(DFN)
SET PSOBSA=$PIECE(PSOBSA,"^",3)
SET PSOBSA=$SELECT(PSOBSA'>0:"_______",1:$JUSTIFY(PSOBSA,4,2))
+1 SET RSLT=$$CRCL^PSOORUT2(DFN)
+2 ; RSLT -- DATE^CRCL^Serum Creatinine -- Ex. 11/25/11^68.7^1.1
+3 ; Display format of CrCL and Creatinine results updated - PSO*7.0*556
+4 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+5 IF ($PIECE($GET(RSLT),"^",2)["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+6 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)<.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_" (CREAT: Not Found)"
+7 IF ($PIECE($GET(RSLT),"^",2)'["Not Found")&($PIECE($GET(RSLT),"^",3)>=.01)
SET ZDSPL=" CrCL: "_$PIECE(RSLT,"^",2)_"(est.)"_" (CREAT: "_$PIECE($GET(RSLT),"^",3)_"mg/dL "_$PIECE($GET(RSLT),"^")_")"
+8 WRITE !,$GET(ZDSPL),?40," BSA (m2): ",PSOBSA
KILL PSOBSA,ZDSPL,RSLT
+9 ;
+10 SET PSLC=0
if $PIECE($GET(^DPT(DFN,.17)),"^",2)'="I"
GOTO MA
+11 IF '$DATA(VAEL(1))
DO ELIG^VADPT
WRITE !!,"ELIGIBILITY: ",$PIECE(VAEL(1),"^",2)
if +VAEL(3)
WRITE ?$X+5,"SC%: "_$PIECE(VAEL(3),"^",2)
SET PSLC=PSLC+2
MA KILL SC
WRITE !,"DISABILITIES: "
SET PSLC=PSLC+2
+1 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^DPT(DFN,.372,I,0)):^(0),1:"")
if +I1
Begin DoDot:1
+2 SET PSDIS=$SELECT($PIECE($GET(^DIC(31,+I1,0)),"^")]""&($PIECE($GET(^(0)),"^",4)']""):$PIECE(^(0),"^"),$PIECE($GET(^DIC(31,+I1,0)),"^",4)]"":$PIECE(^(0),"^",4),1:"")
SET PSCNT=$PIECE(I1,"^",2)
+3 if ($X+$LENGTH(PSDIS)+7)>(IOM-8)
XECUTE "W !?14 S PSLC=PSLC+1"
WRITE PSDIS,"-",PSCNT,"% (",$SELECT($PIECE(I1,"^",3):"SC",1:"NSC"),"), "
+4 IF $EXTRACT(IOST)="C"
IF $Y+4>IOSL
IF $DATA(PSTYPE)
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DTOUT
WRITE @IOF,?13
End DoDot:1
+5 XECUTE "N X S X=""GMRADPT"" X ^%ZOSF(""TEST"") Q"
IF $TEST
if '$DATA(PSOPTPST)
DO GMRA
+6 DO WH
Q KILL SC,I1,VAROOT,Y,AL,I,X,Y,PSCNT,PSLC,PSDIS
if $GET(PSTYPE)']""
DO KVA^VADPT
QUIT
GMRA KILL ^TMP($JOB,"AL")
SET GMRA="0^0^111"
DO ^GMRADPT
IF GMRAL
Begin DoDot:1
+1 FOR DR=0:0
SET DR=$ORDER(GMRAL(DR))
if 'DR
QUIT
SET ^TMP($JOB,"AL",$SELECT('$PIECE(GMRAL(DR),"^",5):1,1:2),$PIECE(GMRAL(DR),"^",7),$PIECE(GMRAL(DR),"^",2))=""
+2 WRITE !!,"ALLERGIES: "
SET (DR,TY)=""
FOR I=0:0
SET TY=$ORDER(^TMP($JOB,"AL",1,TY))
if TY=""
QUIT
FOR D=0:0
SET DR=$ORDER(^TMP($JOB,"AL",1,TY,DR))
if DR=""
QUIT
if $X+$LENGTH(DR)+$LENGTH(", ")>IOM
WRITE !?11
WRITE DR_", "
Begin DoDot:2
+3 IF $EXTRACT(IOST)="C"
IF $Y+4>IOSL
IF $DATA(PSTYPE)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DTOUT
WRITE @IOF,?18
End DoDot:2
+4 WRITE !!,"ADVERSE REACTIONS: "
SET (DR,TY)=""
FOR I=0:0
SET TY=$ORDER(^TMP($JOB,"AL",2,TY))
if TY=""
QUIT
FOR D=0:0
SET DR=$ORDER(^TMP($JOB,"AL",2,TY,DR))
if DR=""
QUIT
if $X+$LENGTH(DR)+$LENGTH(", ")>IOM
WRITE !?19
WRITE DR_", "
Begin DoDot:2
+5 IF $EXTRACT(IOST)="C"
IF $Y+4>IOSL
IF $DATA(PSTYPE)
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue"
DO ^DIR
KILL DIR,DTOUT
WRITE @IOF,?18
End DoDot:2
End DoDot:1
+6 IF $GET(GMRAL)']""
FOR AD="ALLERGIES:","ADVERSE REACTIONS:"
WRITE !!,AD
IF $GET(PSOFROM)=""
FOR ADL=1:1:IOM-($LENGTH(AD)+5)
WRITE "_"
+7 IF GMRAL=0
WRITE !!,"ALLERGIES: NKA",!!,"ADVERSE REACTIONS:"
+8 WRITE !
KILL TY,D,I,GMRA,GMRAL,DR,AD,ADL,^TMP($JOB,"AL")
QUIT
WH ; WOMEN'S HEALTH
+1 IF $PIECE(VADM(5),U,1)="F"
WRITE !,"WOMEN'S HEALTH: ",$$GETSTATUS^WVRPCPT(DFN),!
+2 QUIT
