PSOARCLT ;BHAM ISC/LGH - list archived prescriptions ; 11/17/92 18:17
;;7.0;OUTPATIENT PHARMACY;**10**;DEC 1997
AC W !!!!
S DIC("S")="I $O(^PS(55,+Y,""ARC"",0))",DIC=55,DIC(0)="AEQM",DIC("A")="Show archived prescriptions for: " D ^DIC K DIC G DONE:Y<0 S (DA,DFN)=+Y D:$P($G(^PS(55,DFN,0)),"^",6)'=2 EN^PSOHLUP(DFN)
I '$O(^PS(55,DA,"ARC",0)) W !,"Patient has no archived prescriptions !",! G PSOARCLT
;
S %ZIS="MNQ" D ^%ZIS G DONE:POP I IO'=IO(0) S ZTDTH=$H,ZTRTN="GET^PSOARCLT",ZTDESC="Option to print archived prescriptions",ZTSAVE("DA")=DA D ^%ZTLOAD D ^%ZISC K ZTDTH,ZTRTN,ZTDESC,ZTSAVE G PSOARCLT
D GET R !," Please press RETURN to continue",Z:DTIME G PSOARCLT:$T
DONE D ^%ZISC K DA,DFN,J1,JJ,KK,SC,TEMP,X,Y,Z,SUB,XY,SL,FF,BS,XI,VA("PID"),VA("BID") Q
GET S DFN=DA
D ADD^VADPT,DEM^VADPT,ELIG^VADPT
W @IOF,!,$G(VADM(1)),?40,"ID#: ",$P($G(VADM(2)),"^",2)
I $G(VAPA(10)),$G(VAPA(9)),(DT'>$G(VAPA(10))) S Y=VAPA(9) X:Y ^DD("DD") W !?5,"(TEMP ADDRESS from "_Y S Y=VAPA(10) X:Y ^DD("DD") W " till "_Y_")"
W !,$G(VAPA(1)),?40,"DOB: ",$S($G(VADM(3)):$E($P(VADM(3),"^"),4,5)_"-"_$E($P(VADM(3),"^"),6,7)_"-"_(1700+$E($P(VADM(3),"^"),1,3)),1:"UNKNOWN")
W !,$G(VAPA(4)),?40,"PHONE: ",$G(VAPA(8))
W !,$P($G(VAPA(5)),"^",2)
W " ",$G(VAPA(6)),?40,"ELIG: " I $G(VAEL(1)) S SC=$P($G(VAEL(1)),"^",2) W SC
I $D(^PS(55,DFN,0)),+$P(^(0),"^",2) W !,"CANNOT USE SAFETY CAPS."
I +$P(^PS(55,DFN,0),"^",4) W ?40,"DIALYSIS PATIENT."
I $D(^PS(55,DFN,1)),^(1)]"" S X=^(1) W !!?5,"Pharmacy narrative: " F I=1:1 Q:$P(X," ",I,99)="" W $P(X," ",I)," " W:$X>75 !
RE S PSLC=0 G END:'$D(^DPT(DFN,.17)) G END:$P(^(.17),"^",2)'="I"
W !!,"ELIGIBILITY: ",SC S PSLC=PSLC+2
K SC W !,"DISABILITIES: " S PSLC=PSLC+2 G END:'$D(^DPT(DFN,.372))
F I=0:0 S I=$O(^DPT(DFN,.372,I)) Q:'I S I1=$S($D(^(I,0)):^(0),1:""),PSDIS=$S($D(^DIC(31,+I1,0)):$P(^(0),"^"),1:""),PSCNT=$P(I1,"^",2) X:($X+$L(PSDIS)+7)>72 "W !?10 S PSLC=PSLC+1" W PSDIS,"-",PSCNT,"% (",$S($P(I1,"^",3):"SC",1:"NSC"),"), "
D KVA^VADPT
END ;
D HOME^%ZIS W !!,"ARCHIVED: " S PSOD=0,U="^" F JJ=0:0 W:PSOD'=0 !?10 S PSOD=$O(^PS(55,DA,"ARC",PSOD)) Q:'PSOD D W
K PSOD,PSOR,PSORR
I $E(IOST)="P",$D(IOF),IOF]"" W @IOF
S:$D(ZTQUEUED) ZTREQ="@"
Q
W Q:'$D(^PS(55,DA,"ARC",PSOD,1,0)) Q:$P(^PS(55,DA,"ARC",PSOD,1,0),U,4)'>0 S PSOR=0 W $E(PSOD,4,5),"/",$E(PSOD,6,7),"/",$E(PSOD,2,3)," - "
F KK=0:0 S PSOR=$O(^PS(55,DA,"ARC",PSOD,1,PSOR)) Q:'PSOR D P
Q
P Q:$L(^PS(55,DA,"ARC",PSOD,1,PSOR,0))<1 S PSORR=^PS(55,DA,"ARC",PSOD,1,PSOR,0)
F J1=1:1 Q:$P(PSORR,"*",J1)="" W:($X+$L($P(PSORR,"*",J1))+1)>IOM !?21 W $P(PSORR,"*",J1),","
Q
Q K SC,Y,LMI,TEMP,TMPDT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCLT 2637 printed Oct 16, 2024@18:24:57 Page 2
PSOARCLT ;BHAM ISC/LGH - list archived prescriptions ; 11/17/92 18:17
+1 ;;7.0;OUTPATIENT PHARMACY;**10**;DEC 1997
AC WRITE !!!!
+1 SET DIC("S")="I $O(^PS(55,+Y,""ARC"",0))"
SET DIC=55
SET DIC(0)="AEQM"
SET DIC("A")="Show archived prescriptions for: "
DO ^DIC
KILL DIC
if Y<0
GOTO DONE
SET (DA,DFN)=+Y
if $PIECE($GET(^PS(55,DFN,0)),"^",6)'=2
DO EN^PSOHLUP(DFN)
+2 IF '$ORDER(^PS(55,DA,"ARC",0))
WRITE !,"Patient has no archived prescriptions !",!
GOTO PSOARCLT
+3 ;
+4 SET %ZIS="MNQ"
DO ^%ZIS
if POP
GOTO DONE
IF IO'=IO(0)
SET ZTDTH=$HOROLOG
SET ZTRTN="GET^PSOARCLT"
SET ZTDESC="Option to print archived prescriptions"
SET ZTSAVE("DA")=DA
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTDTH,ZTRTN,ZTDESC,ZTSAVE
GOTO PSOARCLT
+5 DO GET
READ !," Please press RETURN to continue",Z:DTIME
if $TEST
GOTO PSOARCLT
DONE DO ^%ZISC
KILL DA,DFN,J1,JJ,KK,SC,TEMP,X,Y,Z,SUB,XY,SL,FF,BS,XI,VA("PID"),VA("BID")
QUIT
GET SET DFN=DA
+1 DO ADD^VADPT
DO DEM^VADPT
DO ELIG^VADPT
+2 WRITE @IOF,!,$GET(VADM(1)),?40,"ID#: ",$PIECE($GET(VADM(2)),"^",2)
+3 IF $GET(VAPA(10))
IF $GET(VAPA(9))
IF (DT'>$GET(VAPA(10)))
SET Y=VAPA(9)
if Y
XECUTE ^DD("DD")
WRITE !?5,"(TEMP ADDRESS from "_Y
SET Y=VAPA(10)
if Y
XECUTE ^DD("DD")
WRITE " till "_Y_")"
+4 WRITE !,$GET(VAPA(1)),?40,"DOB: ",$SELECT($GET(VADM(3)):$EXTRACT($PIECE(VADM(3),"^"),4,5)_"-"_$EXTRACT($PIECE(VADM(3),"^"),6,7)_"-"_(1700+$EXTRACT($PIECE(VADM(3),"^"),1,3)),1:"UNKNOWN")
+5 WRITE !,$GET(VAPA(4)),?40,"PHONE: ",$GET(VAPA(8))
+6 WRITE !,$PIECE($GET(VAPA(5)),"^",2)
+7 WRITE " ",$GET(VAPA(6)),?40,"ELIG: "
IF $GET(VAEL(1))
SET SC=$PIECE($GET(VAEL(1)),"^",2)
WRITE SC
+8 IF $DATA(^PS(55,DFN,0))
IF +$PIECE(^(0),"^",2)
WRITE !,"CANNOT USE SAFETY CAPS."
+9 IF +$PIECE(^PS(55,DFN,0),"^",4)
WRITE ?40,"DIALYSIS PATIENT."
+10 IF $DATA(^PS(55,DFN,1))
IF ^(1)]""
SET X=^(1)
WRITE !!?5,"Pharmacy narrative: "
FOR I=1:1
if $PIECE(X," ",I,99)=""
QUIT
WRITE $PIECE(X," ",I)," "
if $X>75
WRITE !
RE SET PSLC=0
if '$DATA(^DPT(DFN,.17))
GOTO END
if $PIECE(^(.17),"^",2)'="I"
GOTO END
+1 WRITE !!,"ELIGIBILITY: ",SC
SET PSLC=PSLC+2
+2 KILL SC
WRITE !,"DISABILITIES: "
SET PSLC=PSLC+2
if '$DATA(^DPT(DFN,.372))
GOTO END
+3 FOR I=0:0
SET I=$ORDER(^DPT(DFN,.372,I))
if 'I
QUIT
SET I1=$SELECT($DATA(^(I,0)):^(0),1:"")
SET PSDIS=$SELECT($DATA(^DIC(31,+I1,0)):$PIECE(^(0),"^"),1:"")
SET PSCNT=$PIECE(I1,"^",2)
if ($X+$LENGTH(PSDIS)+7)>72
XECUTE "W !?10 S PSLC=PSLC+1"
WRITE PSDIS,"-",PSCNT,"% (",$SELECT($PIECE(I1,"^",3):"SC",1:"NSC"),"), "
+4 DO KVA^VADPT
END ;
+1 DO HOME^%ZIS
WRITE !!,"ARCHIVED: "
SET PSOD=0
SET U="^"
FOR JJ=0:0
if PSOD'=0
WRITE !?10
SET PSOD=$ORDER(^PS(55,DA,"ARC",PSOD))
if 'PSOD
QUIT
DO W
+2 KILL PSOD,PSOR,PSORR
+3 IF $EXTRACT(IOST)="P"
IF $DATA(IOF)
IF IOF]""
WRITE @IOF
+4 if $DATA(ZTQUEUED)
SET ZTREQ="@"
+5 QUIT
W if '$DATA(^PS(55,DA,"ARC",PSOD,1,0))
QUIT
if $PIECE(^PS(55,DA,"ARC",PSOD,1,0),U,4)'>0
QUIT
SET PSOR=0
WRITE $EXTRACT(PSOD,4,5),"/",$EXTRACT(PSOD,6,7),"/",$EXTRACT(PSOD,2,3)," - "
+1 FOR KK=0:0
SET PSOR=$ORDER(^PS(55,DA,"ARC",PSOD,1,PSOR))
if 'PSOR
QUIT
DO P
+2 QUIT
P if $LENGTH(^PS(55,DA,"ARC",PSOD,1,PSOR,0))<1
QUIT
SET PSORR=^PS(55,DA,"ARC",PSOD,1,PSOR,0)
+1 FOR J1=1:1
if $PIECE(PSORR,"*",J1)=""
QUIT
if ($X+$LENGTH($PIECE(PSORR,"*",J1))+1)>IOM
WRITE !?21
WRITE $PIECE(PSORR,"*",J1),","
+2 QUIT
Q KILL SC,Y,LMI,TEMP,TMPDT
QUIT
