- 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
- 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">GET(VADM(1)),?40,"ID#: ",$PIECE($GET">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">GET(VAPA(1)),?40,"DOB: ",$SELECT($GET">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">GET(VAPA(4)),?40,"PHONE: ",$GET">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
