- PSOSD3 ;BHAM ISC/RTR - Prints pending orders on action profile ;29-May-2012 15:14;PLS
- ;;7.0;OUTPATIENT PHARMACY;**2,19,107,110,132,1005,1006,233,258,326,1015**;DEC 1997;Build 62
- ;External reference ^PS(50.7 - 2223
- ;External reference ^PS(50.606 - 2174
- ;External reference ^PSDRUG( - 221
- ;External reference ^PS(59.7 - 694
- ;External reference to ^PS(55 - 2228
- ;
- ; Modified - IHS/CIA/PLS - 12/10/03 - Line HD1+8 and HD1+17
- ; IHS/MSC/PLS - 10/11/07 - Non-VA MEDS to Outside Medications
- START Q:$D(DUOUT)!($D(DTOUT))!('$G(DFN))
- N MMM,PNDIS,PNDLINE,PNDREX,PNPOI,PPPP,PSOPRVD,PSCONT,PSOEFF,PSOQTY,PSOREFLS,PZSTAT,WWW
- D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
- S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2)
- K ^TMP($J,"PSOPEND") S $P(PNDLINE,"-",33)=""
- S PSCONT=1 F MMM=0:0 S MMM=$O(^PS(52.41,"P",DFN,MMM)) Q:'MMM S PZSTAT=$P($G(^PS(52.41,MMM,0)),"^",3) I PZSTAT="NW"!(PZSTAT="HD")!(PZSTAT="RNW") D
- .S ^TMP($J,"PSOPEND",PSCONT)=MMM_"^"_$S(+$P($G(^PS(52.41,MMM,0)),"^",9):"DD",1:"OI") S PSCONT=PSCONT+1
- I $Y+6>IOSL D HD1 S:$D(DTOUT)!($D(DUOUT)) PSQFLG=1 G:$G(PSQFLG) END
- D HD
- I PSCONT=1 W !?10,"No pending orders for this patient!",! G END
- F WWW=0:0 S WWW=$O(^TMP($J,"PSOPEND",WWW)) Q:'WWW!($G(PSQFLG)) D
- .S PNDREX=$P(^TMP($J,"PSOPEND",WWW),"^"),PNDIS=$P($G(^PS(52.41,PNDREX,0)),"^",9),PNPOI=$P($G(^(0)),"^",8),PSOEFF=$P($G(^(0)),"^",6),PSOQTY=$P($G(^(0)),"^",10),PSOREFLS=$P($G(^(0)),"^",11),PSOPRVD=$P($G(^(0)),"^",5)
- .W !,"Drug: ",$S($P(^TMP($J,"PSOPEND",WWW),"^",2)="DD":$P($G(^PSDRUG(+PNDIS,0)),"^"),1:$P($G(^PS(50.7,+PNPOI,0)),"^")_" "_$P($G(^PS(50.606,+$P($G(^(0)),"^",2),0)),"^")),!
- .W ?1,"Eff. Date: ",$E(PSOEFF,4,5)_"-"_$E(PSOEFF,6,7)_"-"_($E(PSOEFF,1,3)+1700),?22,"Qty: ",PSOQTY,?40,"Refills: ",PSOREFLS,?52,"Prov: ",$E($P($G(^VA(200,+PSOPRVD,0)),"^"),1,21)
- .S PSCONT=1 W !?1,"Sig: " F PPPP=0:0 S PPPP=$O(^PS(52.41,PNDREX,"SIG",PPPP)) Q:'PPPP!($G(PSQFLG)) W:PSCONT>1 ! W ?6,$G(^PS(52.41,PNDREX,"SIG",PPPP,0)) S PSCONT=PSCONT+1
- .I $E(IOST)'="C" W !
- .I $E(IOST)="C" D HD1 S:$D(DUOUT)!($D(DTOUT)) PSQFLG=1 Q:$G(PSQFLG) D HD
- .I $E(IOST)'="C" I $Y+9>IOSL D HD1 S:$D(DUOUT)!($D(DTOUT)) PSQFLG=1 Q:$G(PSQFLG) D HD
- END K ^TMP($J,"PSOPEND") Q
- HD W !,PNDLINE,"PENDING ORDERS",PNDLINE,! Q
- ;
- HD1 S FN=DFN
- I $E(IOST)="C" K DIR S DIR(0)="E",DIR("A")="Press Return to Continue or ""^"" to Exit" D ^DIR Q:$D(DUOUT)!($D(DTOUT))
- D ELIG^PSOSD1,DEM^VADPT,INP^VADPT,ADD^VADPT,PID^VADPT S PSSN=VA("PID"),ADDRFL=$S(+VAPA(9):"Temporary ",1:"")
- S PSNAME=$E(VADM(1),1,28),PSDOB=$P(VADM(3),"^",2)
- I $D(IOF) W @IOF
- W $S(PSTYPE:"Action",1:"Informational")_" Rx Profile",?47,"Run Date: " S Y=DT D DT^DIO2 W ?71,"Page: "_PAGE
- W !,"Sorted by drug classification for Rx's currently active"_$S('PSDAYS:" only.",1:"") W:PSDAYS !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
- S X=$$SITE^VASITE
- ;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
- ;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- W @$S(PSORM:"?70",1:"!"),"Site: "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- I $P(VAIN(4),"^",2)]"",+$P($G(^PS(59.7,1,40.1)),"^") W !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
- I $D(CLINICX) W !?1,"Clinic: "_$E(CLINICX,1,28),?45,"Date/Time: " S Y=CLDT D DT^DIO2
- W !?1,"Name : ",PSNAME W:PSTYPE ?58,"Action Date: ________" W !?1,"DOB : "_PSDOB
- W:ADDRFL]"" ?30,ADDRFL,! W ?30,"Address :"
- I $G(ADDRFL)="" D CHECKBAI^PSOSD1
- W ?41,VAPA(1) W:VAPA(2)]"" !?41,VAPA(2) W:VAPA(3)]"" !?41,VAPA(3)
- W !?41,VAPA(4)_", "_$P(VAPA(5),"^",2)_" "_$S(VAPA(11)]"":$P(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8)
- I PSOBAR4 S X="S",X2=PSSN W @$S('PSORM:"!?30",1:"?$X+5") S X1=$X W @PSOBAR3,X2,@PSOBAR2,$C(13) S $X=0
- W:$G(DOD(DFN))]"" ?1,"**** Date of Death: "_DOD(DFN)_" ****",!
- ; IHS/CIA/PLS - 12/10/03 - Change HT and WT calls to use PCC Vitals
- 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.2,0,2),WT=WT_"^"_Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),HT=HT_"^"_Y
- S WT=$$VITALF^APSPFUNC(DFN,"WT"),$P(WT,U,9)=$$VITCWT^APSPFUNC($P(WT,U,8))
- S HT=$$VITALF^APSPFUNC(DFN,"HT"),$P(HT,U,9)=$$VITCHT^APSPFUNC($P(HT,U,8))
- 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
- S PAGE=PAGE+1 W !,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- Q
- NVA ;displays non-va meds
- Q:'$O(^PS(55,DFN,"NVA",0))
- Q:$D(DUOUT)!($D(DTOUT))!('$G(DFN))
- D HD1 S $P(PNDLINE,"-",IOM)="",PSODFN=DFN
- W !,PNDLINE,!?25,"Outside Medications",!,PNDLINE,! ;,"Non-VA Meds (Not dispensed by VA)",!,PNDLINE,! - IHS/MSC/PLS - 5/14/2010
- F NVA=0:0 S NVA=$O(^PS(55,DFN,"NVA",NVA)) Q:'NVA D Q:$G(PSQFLG)
- .I $Y+6>IOSL D HD1 S:$D(DTOUT)!($D(DUOUT)) PSQFLG=1 Q:$G(PSQFLG)
- .Q:'$P(^PS(55,PSODFN,"NVA",NVA,0),"^")
- .S DUPRX0=^PS(55,PSODFN,"NVA",NVA,0)
- .W !,"Orderable Item: "_$P(^PS(50.7,$P(DUPRX0,"^"),0),"^")_" "_$P(^PS(50.606,$P(^(0),"^",2),0),"^")
- .W !,"Drug: "_$S($P(DUPRX0,"^",2):$P(^PSDRUG($P(DUPRX0,"^",2),0),"^"),1:"No Dispense Drug Selected")
- .W !,"Status: "_$S($P(DUPRX0,"^",7):"Discontinued ("_$$FMTE^XLFDT($P($P(DUPRX0,"^",7),"."))_")",1:"Active")
- .W !,"Dosage: "_$P(DUPRX0,"^",3)
- .W !,"Schedule: "_$P(DUPRX0,"^",5),!,"Route: "_$P(DUPRX0,"^",4)
- .W !,"Start Date: "_$$FMTE^XLFDT($P(DUPRX0,"^",9)),?40,"CPRS Oder #: "_$P(DUPRX0,"^",8)
- .W !,"Documented By: "_$P(^VA(200,$P(DUPRX0,"^",11),0),"^")_" on "_$$FMTE^XLFDT($P(DUPRX0,"^",10))
- .S RMLEN=$S('PSORM:75,1:IOM-5)
- .F I=0:0 S I=$O(^PS(55,PSODFN,"NVA",NVA,"OCK",I)) Q:'I D W !
- ..S ORD=$P(^PS(55,PSODFN,"NVA",NVA,"OCK",I,0),"^"),ORP=$P(^(0),"^",2)
- ..W !,"Order Check #"_I_": "
- ..K OCK,LEN I $L(ORD)>RMLEN S (LEN,IEN)=1 D
- ...F SG=1:1:$L(ORD) S:$L($G(OCK(IEN))_" "_$P(ORD," ",SG))>RMLEN&($P(ORD," ",SG)]"") IEN=IEN+1 S:$P(ORD," ",SG)'="" OCK(IEN)=$G(OCK(IEN))_" "_$P(ORD," ",SG)
- ...F II=0:0 S II=$O(OCK(II)) Q:'II W !?5,OCK(II)
- ..W:'$G(LEN) ORD K LEN,SG,IEN,II,OCK,ORD
- ..W !,"Overriding Provider: "_$S($G(ORP):$P(^VA(200,ORP,0),"^"),1:"")
- ..K ORP,OCK,REA W !,"Reason:" F SS=0:0 S SS=$O(^PS(55,PSODFN,"NVA",NVA,"OCK",I,"OVR",SS)) Q:'SS S REA(SS)=^PS(55,PSODFN,"NVA",NVA,"OCK",I,"OVR",SS,0)
- ..S IEN=1 F II=0:0 S II=$O(REA(II)) Q:'II D
- ...F SG=1:1:$L(REA(II)) S:$L($G(OCK(IEN))_" "_$P(REA(II)," ",SG))>RMLEN&($P(REA(II)," ",SG)]"") IEN=IEN+1 S:$P(REA(II)," ",SG)'="" OCK(IEN)=$G(OCK(IEN))_" "_$P(REA(II)," ",SG)
- ...K REA,IEN,SG F II=0:0 S II=$O(OCK(II)) Q:'II W OCK(II) I $O(OCK(II)) W !?5
- .K OCK W !,"Statement/Explanation/Comments:" F SS=0:0 S SS=$O(^PS(55,PSODFN,"NVA",NVA,"DSC",SS)) Q:'SS S DSC(SS)=^PS(55,PSODFN,"NVA",NVA,"DSC",SS,0)
- .S IEN=1 F II=0:0 S II=$O(DSC(II)) Q:'II D
- ..F SG=1:1:$L(DSC(II)) S:$L($G(OCK(IEN))_" "_$P(DSC(II)," ",SG))>RMLEN&($P(DSC(II)," ",SG)]"") IEN=IEN+1 S:$P(DSC(II)," ",SG)'="" OCK(IEN)=$G(OCK(IEN))_" "_$P(DSC(II)," ",SG)
- .K IEN,DSC,SG F II=0:0 S II=$O(OCK(II)) Q:'II W !?5,OCK(II)
- .W !! I $E(IOST)'="C" W !
- K RMLEN
- Q
- PSOSD3 ;BHAM ISC/RTR - Prints pending orders on action profile ;29-May-2012 15:14;PLS
- +1 ;;7.0;OUTPATIENT PHARMACY;**2,19,107,110,132,1005,1006,233,258,326,1015**;DEC 1997;Build 62
- +2 ;External reference ^PS(50.7 - 2223
- +3 ;External reference ^PS(50.606 - 2174
- +4 ;External reference ^PSDRUG( - 221
- +5 ;External reference ^PS(59.7 - 694
- +6 ;External reference to ^PS(55 - 2228
- +7 ;
- +8 ; Modified - IHS/CIA/PLS - 12/10/03 - Line HD1+8 and HD1+17
- +9 ; IHS/MSC/PLS - 10/11/07 - Non-VA MEDS to Outside Medications
- START IF $DATA(DUOUT)!($DATA(DTOUT))!('$GET(DFN))
- QUIT
- +1 NEW MMM,PNDIS,PNDLINE,PNDREX,PNPOI,PPPP,PSOPRVD,PSCONT,PSOEFF,PSOQTY,PSOREFLS,PZSTAT,WWW
- +2 DO ELIG^PSOSD1
- DO DEM^VADPT
- DO INP^VADPT
- DO ADD^VADPT
- DO PID^VADPT
- SET PSSN=VA("PID")
- SET ADDRFL=$SELECT(+VAPA(9):"Temporary ",1:"")
- +3 SET PSNAME=$EXTRACT(VADM(1),1,28)
- SET PSDOB=$PIECE(VADM(3),"^",2)
- +4 KILL ^TMP($JOB,"PSOPEND")
- SET $PIECE(PNDLINE,"-",33)=""
- +5 SET PSCONT=1
- FOR MMM=0:0
- SET MMM=$ORDER(^PS(52.41,"P",DFN,MMM))
- IF 'MMM
- QUIT
- SET PZSTAT=$PIECE($GET(^PS(52.41,MMM,0)),"^",3)
- IF PZSTAT="NW"!(PZSTAT="HD")!(PZSTAT="RNW")
- Begin DoDot:1
- +6 SET ^TMP($JOB,"PSOPEND",PSCONT)=MMM_"^"_$SELECT(+$PIECE($GET(^PS(52.41,MMM,0)),"^",9):"DD",1:"OI")
- SET PSCONT=PSCONT+1
- End DoDot:1
- +7 IF $Y+6>IOSL
- DO HD1
- IF $DATA(DTOUT)!($DATA(DUOUT))
- SET PSQFLG=1
- IF $GET(PSQFLG)
- GOTO END
- +8 DO HD
- +9 IF PSCONT=1
- WRITE !?10,"No pending orders for this patient!",!
- GOTO END
- +10 FOR WWW=0:0
- SET WWW=$ORDER(^TMP($JOB,"PSOPEND",WWW))
- IF 'WWW!($GET(PSQFLG))
- QUIT
- Begin DoDot:1
- +11 SET PNDREX=$PIECE(^TMP($JOB,"PSOPEND",WWW),"^")
- SET PNDIS=$PIECE($GET(^PS(52.41,PNDREX,0)),"^",9)
- SET PNPOI=$PIECE($GET(^(0)),"^",8)
- SET PSOEFF=$PIECE($GET(^(0)),"^",6)
- SET PSOQTY=$PIECE($GET(^(0)),"^",10)
- SET PSOREFLS=$PIECE($GET(^(0)),"^",11)
- SET PSOPRVD=$PIECE($GET(^(0)),"^",5)
- +12 WRITE !,"Drug: ",$SELECT($PIECE(^TMP($JOB,"PSOPEND",WWW),"^",2)="DD":$PIECE($GET(^PSDRUG(+PNDIS,0)),"^"),1:$PIECE($GET(^PS(50.7,+PNPOI,0)),"^")_" "_$PIECE($GET(^PS(50.606,+$PIECE($GET(^(0)),"^",2),0)),"^")),!
- +13 WRITE ?1,"Eff. Date: ",$EXTRACT(PSOEFF,4,5)_"-"_$EXTRACT(PSOEFF,6,7)_"-"_($EXTRACT(PSOEFF,1,3)+1700),?22,"Qty: ",PSOQTY,?40,"Refills: ",PSOREFLS,?52,"Prov: ",$EXTRACT($PIECE($GET(^VA(200,+PSOPRVD,0)),"^"),1,21)
- +14 SET PSCONT=1
- WRITE !?1,"Sig: "
- FOR PPPP=0:0
- SET PPPP=$ORDER(^PS(52.41,PNDREX,"SIG",PPPP))
- IF 'PPPP!($GET(PSQFLG))
- QUIT
- IF PSCONT>1
- WRITE !
- WRITE ?6,$GET(^PS(52.41,PNDREX,"SIG",PPPP,0))
- SET PSCONT=PSCONT+1
- +15 IF $EXTRACT(IOST)'="C"
- WRITE !
- +16 IF $EXTRACT(IOST)="C"
- DO HD1
- IF $DATA(DUOUT)!($DATA(DTOUT))
- SET PSQFLG=1
- IF $GET(PSQFLG)
- QUIT
- DO HD
- +17 IF $EXTRACT(IOST)'="C"
- IF $Y+9>IOSL
- DO HD1
- IF $DATA(DUOUT)!($DATA(DTOUT))
- SET PSQFLG=1
- IF $GET(PSQFLG)
- QUIT
- DO HD
- End DoDot:1
- END KILL ^TMP($JOB,"PSOPEND")
- QUIT
- HD WRITE !,PNDLINE,"PENDING ORDERS",PNDLINE,!
- QUIT
- +1 ;
- HD1 SET FN=DFN
- +1 IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="Press Return to Continue or ""^"" to Exit"
- DO ^DIR
- IF $DATA(DUOUT)!($DATA(DTOUT))
- QUIT
- +2 DO ELIG^PSOSD1
- DO DEM^VADPT
- DO INP^VADPT
- DO ADD^VADPT
- DO PID^VADPT
- SET PSSN=VA("PID")
- SET ADDRFL=$SELECT(+VAPA(9):"Temporary ",1:"")
- +3 SET PSNAME=$EXTRACT(VADM(1),1,28)
- SET PSDOB=$PIECE(VADM(3),"^",2)
- +4 IF $DATA(IOF)
- WRITE @IOF
- +5 WRITE $SELECT(PSTYPE:"Action",1:"Informational")_" Rx Profile",?47,"Run Date: "
- SET Y=DT
- DO DT^DIO2
- WRITE ?71,"Page: "_PAGE
- +6 WRITE !,"Sorted by drug classification for Rx's currently active"_$SELECT('PSDAYS:" only.",1:"")
- IF PSDAYS
- WRITE !,"and for those Rx's that have been inactive less than "_PSDAYS_" days."
- +7 SET X=$$SITE^VASITE
- +8 ;IHS/CIA/PLS - 01/28/04 - Removed references to VAMC
- +9 ;W @$S(PSORM:"?70",1:"!"),"Site: VAMC "_$P(X,"^",2)_" ("_$P(X,"^",3)_")",!,$E(LINE,1,$S('PSORM:80,1:IOM)-1)
- +10 WRITE @$SELECT(PSORM:"?70",1:"!"),"Site: "_$PIECE(X,"^",2)_" ("_$PIECE(X,"^",3)_")",!,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1)
- +11 IF $PIECE(VAIN(4),"^",2)]""
- IF +$PIECE($GET(^PS(59.7,1,40.1)),"^")
- WRITE !,"Outpatient prescriptions are discontinued 72 hours after admission.",!
- +12 IF $DATA(CLINICX)
- WRITE !?1,"Clinic: "_$EXTRACT(CLINICX,1,28),?45,"Date/Time: "
- SET Y=CLDT
- DO DT^DIO2
- +13 WRITE !?1,"Name : ",PSNAME
- IF PSTYPE
- WRITE ?58,"Action Date: ________"
- WRITE !?1,"DOB : "_PSDOB
- +14 IF ADDRFL]""
- WRITE ?30,ADDRFL,!
- WRITE ?30,"Address :"
- +15 IF $GET(ADDRFL)=""
- DO CHECKBAI^PSOSD1
- +16 WRITE ?41,VAPA(1)
- IF VAPA(2)]""
- WRITE !?41,VAPA(2)
- IF VAPA(3)]""
- WRITE !?41,VAPA(3)
- +17 WRITE !?41,VAPA(4)_", "_$PIECE(VAPA(5),"^",2)_" "_$SELECT(VAPA(11)]"":$PIECE(VAPA(11),"^",2),1:VAPA(6)),!?30,"Phone : "_VAPA(8)
- +18 IF PSOBAR4
- SET X="S"
- SET X2=PSSN
- WRITE @$SELECT('PSORM:"!?30",1:"?$X+5")
- SET X1=$X
- WRITE @PSOBAR3,X2,@PSOBAR2,$CHAR(13)
- SET $X=0
- +19 IF $GET(DOD(DFN))]""
- WRITE ?1,"**** Date of Death: "_DOD(DFN)_" ****",!
- +20 ; IHS/CIA/PLS - 12/10/03 - Change HT and WT calls to use PCC Vitals
- +21 ;,X="GMRVUTL" X ^%ZOSF("TEST") I $T D
- SET (WT,HT)=""
- +22 ;.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)
- +23 ;.S X=$P(WT,"^",8),Y=$J(X/2.2,0,2),WT=WT_"^"_Y,X=$P(HT,"^",8),Y=$J(2.54*X,0,2),HT=HT_"^"_Y
- +24 SET WT=$$VITALF^APSPFUNC(DFN,"WT")
- SET $PIECE(WT,U,9)=$$VITCWT^APSPFUNC($PIECE(WT,U,8))
- +25 SET HT=$$VITALF^APSPFUNC(DFN,"HT")
- SET $PIECE(HT,U,9)=$$VITCHT^APSPFUNC($PIECE(HT,U,8))
- +26 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
- +27 SET PAGE=PAGE+1
- WRITE !,$EXTRACT(LINE,1,$SELECT('PSORM:80,1:IOM)-1)
- +28 QUIT
- NVA ;displays non-va meds
- +1 IF '$ORDER(^PS(55,DFN,"NVA",0))
- QUIT
- +2 IF $DATA(DUOUT)!($DATA(DTOUT))!('$GET(DFN))
- QUIT
- +3 DO HD1
- SET $PIECE(PNDLINE,"-",IOM)=""
- SET PSODFN=DFN
- +4 ;,"Non-VA Meds (Not dispensed by VA)",!,PNDLINE,! - IHS/MSC/PLS - 5/14/2010
- WRITE !,PNDLINE,!?25,"Outside Medications",!,PNDLINE,!
- +5 FOR NVA=0:0
- SET NVA=$ORDER(^PS(55,DFN,"NVA",NVA))
- IF 'NVA
- QUIT
- Begin DoDot:1
- +6 IF $Y+6>IOSL
- DO HD1
- IF $DATA(DTOUT)!($DATA(DUOUT))
- SET PSQFLG=1
- IF $GET(PSQFLG)
- QUIT
- +7 IF '$PIECE(^PS(55,PSODFN,"NVA",NVA,0),"^")
- QUIT
- +8 SET DUPRX0=^PS(55,PSODFN,"NVA",NVA,0)
- +9 WRITE !,"Orderable Item: "_$PIECE(^PS(50.7,$PIECE(DUPRX0,"^"),0),"^")_" "_$PIECE(^PS(50.606,$PIECE(^(0),"^",2),0),"^")
- +10 WRITE !,"Drug: "_$SELECT($PIECE(DUPRX0,"^",2):$PIECE(^PSDRUG($PIECE(DUPRX0,"^",2),0),"^"),1:"No Dispense Drug Selected")
- +11 WRITE !,"Status: "_$SELECT($PIECE(DUPRX0,"^",7):"Discontinued ("_$$FMTE^XLFDT($PIECE($PIECE(DUPRX0,"^",7),"."))_")",1:"Active")
- +12 WRITE !,"Dosage: "_$PIECE(DUPRX0,"^",3)
- +13 WRITE !,"Schedule: "_$PIECE(DUPRX0,"^",5),!,"Route: "_$PIECE(DUPRX0,"^",4)
- +14 WRITE !,"Start Date: "_$$FMTE^XLFDT($PIECE(DUPRX0,"^",9)),?40,"CPRS Oder #: "_$PIECE(DUPRX0,"^",8)
- +15 WRITE !,"Documented By: "_$PIECE(^VA(200,$PIECE(DUPRX0,"^",11),0),"^")_" on "_$$FMTE^XLFDT($PIECE(DUPRX0,"^",10))
- +16 SET RMLEN=$SELECT('PSORM:75,1:IOM-5)
- +17 FOR I=0:0
- SET I=$ORDER(^PS(55,PSODFN,"NVA",NVA,"OCK",I))
- IF 'I
- QUIT
- Begin DoDot:2
- +18 SET ORD=$PIECE(^PS(55,PSODFN,"NVA",NVA,"OCK",I,0),"^")
- SET ORP=$PIECE(^(0),"^",2)
- +19 WRITE !,"Order Check #"_I_": "
- +20 KILL OCK,LEN
- IF $LENGTH(ORD)>RMLEN
- SET (LEN,IEN)=1
- Begin DoDot:3
- +21 FOR SG=1:1:$LENGTH(ORD)
- IF $LENGTH($GET(OCK(IEN))_" "_$PIECE(ORD," ",SG))>RMLEN&($PIECE(ORD," ",SG)]"")
- SET IEN=IEN+1
- IF $PIECE(ORD," ",SG)'=""
- SET OCK(IEN)=$GET(OCK(IEN))_" "_$PIECE(ORD," ",SG)
- +22 FOR II=0:0
- SET II=$ORDER(OCK(II))
- IF 'II
- QUIT
- WRITE !?5,OCK(II)
- End DoDot:3
- +23 IF '$GET(LEN)
- WRITE ORD
- KILL LEN,SG,IEN,II,OCK,ORD
- +24 WRITE !,"Overriding Provider: "_$SELECT($GET(ORP):$PIECE(^VA(200,ORP,0),"^"),1:"")
- +25 KILL ORP,OCK,REA
- WRITE !,"Reason:"
- FOR SS=0:0
- SET SS=$ORDER(^PS(55,PSODFN,"NVA",NVA,"OCK",I,"OVR",SS))
- IF 'SS
- QUIT
- SET REA(SS)=^PS(55,PSODFN,"NVA",NVA,"OCK",I,"OVR",SS,0)
- +26 SET IEN=1
- FOR II=0:0
- SET II=$ORDER(REA(II))
- IF 'II
- QUIT
- Begin DoDot:3
- +27 FOR SG=1:1:$LENGTH(REA(II))
- IF $LENGTH($GET(OCK(IEN))_" "_$PIECE(REA(II)," ",SG))>RMLEN&($PIECE(REA(II)," ",SG)]"")
- SET IEN=IEN+1
- IF $PIECE(REA(II)," ",SG)'=""
- SET OCK(IEN)=$GET(OCK(IEN))_" "_$PIECE(REA(II)," ",SG)
- +28 KILL REA,IEN,SG
- FOR II=0:0
- SET II=$ORDER(OCK(II))
- IF 'II
- QUIT
- WRITE OCK(II)
- IF $ORDER(OCK(II))
- WRITE !?5
- End DoDot:3
- End DoDot:2
- WRITE !
- +29 KILL OCK
- WRITE !,"Statement/Explanation/Comments:"
- FOR SS=0:0
- SET SS=$ORDER(^PS(55,PSODFN,"NVA",NVA,"DSC",SS))
- IF 'SS
- QUIT
- SET DSC(SS)=^PS(55,PSODFN,"NVA",NVA,"DSC",SS,0)
- +30 SET IEN=1
- FOR II=0:0
- SET II=$ORDER(DSC(II))
- IF 'II
- QUIT
- Begin DoDot:2
- +31 FOR SG=1:1:$LENGTH(DSC(II))
- IF $LENGTH($GET(OCK(IEN))_" "_$PIECE(DSC(II)," ",SG))>RMLEN&($PIECE(DSC(II)," ",SG)]"")
- SET IEN=IEN+1
- IF $PIECE(DSC(II)," ",SG)'=""
- SET OCK(IEN)=$GET(OCK(IEN))_" "_$PIECE(DSC(II)," ",SG)
- End DoDot:2
- +32 KILL IEN,DSC,SG
- FOR II=0:0
- SET II=$ORDER(OCK(II))
- IF 'II
- QUIT
- WRITE !?5,OCK(II)
- +33 WRITE !!
- IF $EXTRACT(IOST)'="C"
- WRITE !
- End DoDot:1
- IF $GET(PSQFLG)
- QUIT
- +34 KILL RMLEN
- +35 QUIT
