- PSOLBLD1 ;BHAM ISC/RTR-Prints allergy warning label ; 2/20/95
- ;;7.0;OUTPATIENT PHARMACY;**117**;DEC 1997
- ;
- N AAA,DATE1,EXPDT,ISD,HARDCOPY,PSAA,PSAQUIT,PSBQUIT,PSCQUIT,BBBB,ICOUNT,PSOING,NOW,TB1,TB2,TB2,SSG
- S HARDCOPY=COPIES
- START ;
- S COPIES=COPIES-1,Y=$P(^PSRX(RX,2),"^",6) X ^DD("DD") S EXPDT=Y,Y=$P(^PSRX(RX,0),"^",13) X ^DD("DD") S ISD=Y
- S Y=DATE X ^DD("DD") S DATE1=Y D NOW^%DTC S Y=% X ^DD("DD") S NOW=Y
- S:'$P($G(^PS(59,+$G(PSOSITE),1)),"^",28) TB1=38,TB2=50,TB3=83 S:$P($G(^PS(59,+$G(PSOSITE),1)),"^",28) TB1=54,TB2=66,TB3=102
- PRINT ;
- W !,"***********************************",?TB3 W:$G(RXRP(RX)) "(REPRINT)" I '$G(RXRP(RX)) W $P(PS2,"^",2)," ","("_$P(RXY,"^",16)_"/"_$S(+$G(VRPH):VRPH,1:" ")_")"_" ",$P(NOW,":",1,2)
- W !,"* THIS MEDICATION HAS INDICATED A *",?TB1,"PRESCRIPTION # "_RXN_" HAS",?TB3,RXN," ",DATE1," Fill 1 of ",1+$P(RXY,"^",9)
- W !,"* DRUG ALLERGY *",?TB1,"INDICATED A DRUG ALLERGY:",?TB3,PNM," ",SSNP
- W !,"***********************************"
- S PSOING(1)="",PSOING(2)=$G(DRUG) I $O(^PSRX(RX,"DAI",0)) D
- .S PSOING(3)=" "_"INGREDIENTS:" S ICOUNT=4 F BBBB=0:0 S BBBB=$O(^PSRX(RX,"DAI",BBBB)) Q:'BBBB S PSOING(ICOUNT)=" "_$G(^(BBBB,0)) S ICOUNT=ICOUNT+1
- S (PSAQUIT,PSBQUIT,PSCQUIT)=0 F ICOUNT=1:1 Q:$G(PSCQUIT) D
- .W ?TB1,$G(PSOING(ICOUNT)) S:'$O(PSOING(ICOUNT)) PSAQUIT=1
- .W ?TB3,$S($G(OSGY(ICOUNT))]"":OSGY(ICOUNT),1:$G(SGY(ICOUNT))),! S:'$O(SGY(ICOUNT)) PSBQUIT=1
- .I PSAQUIT,PSBQUIT S PSCQUIT=1
- W !!,?TB1,"THIS PRESCRIPTION WAS ENTERED BY",?TB3,"Qty: ",$G(QTY)," ",$G(PHYS)
- W !,?TB1,$G(TECH),?TB3,"Tech__________RPh__________"
- W !,?TB1,"THIS PRESCRIPTION MAY REQUIRE",?TB3,$G(DRUG)
- W !,?TB1,"REVIEWING BY A PHARMACIST",?TB3,"Routing: "_$S("W"[$E(MW):MW,1:MW_" MAIL")
- W !,?TB3,"Days Supply: ",$G(DAYS)," Cap: ",$S(PSCAP:"**NON-SFTY**",1:"SAFETY")
- W !,?TB3,"Isd: ",ISD," Exp: ",EXPDT
- W !,?TB3,"Last Fill: ",$G(PSOLASTF)
- W !,?TB3,"Pat. Stat ",PATST," Clinic: ",PSCLN
- W @IOF
- I COPIES>0 G START
- S COPIES=HARDCOPY K HARDCOPY
- ;
- STORE ;ALLERGY LABEL PRINT NODE - SHOULD ALWAYS BE ON THE ORIGINAL
- D NOW^%DTC S NOW=% S PSAA=0 F AAA=0:0 S AAA=$O(^PSRX(RX,"L",AAA)) Q:'AAA S PSAA=AAA
- S PSAA=PSAA+1,^PSRX(RX,"L",0)="^52.032DA^"_PSAA_"^"_PSAA,^PSRX(RX,"L",PSAA,0)=NOW_"^"_0_"^Allergy warning label"_$S($G(RXRP(RX)):" (Reprint)",1:"")_"^"_PDUZ_"^2"
- END ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOLBLD1 2358 printed Feb 18, 2025@23:56:52 Page 2
- PSOLBLD1 ;BHAM ISC/RTR-Prints allergy warning label ; 2/20/95
- +1 ;;7.0;OUTPATIENT PHARMACY;**117**;DEC 1997
- +2 ;
- +3 NEW AAA,DATE1,EXPDT,ISD,HARDCOPY,PSAA,PSAQUIT,PSBQUIT,PSCQUIT,BBBB,ICOUNT,PSOING,NOW,TB1,TB2,TB2,SSG
- +4 SET HARDCOPY=COPIES
- START ;
- +1 SET COPIES=COPIES-1
- SET Y=$PIECE(^PSRX(RX,2),"^",6)
- XECUTE ^DD("DD")
- SET EXPDT=Y
- SET Y=$PIECE(^PSRX(RX,0),"^",13)
- XECUTE ^DD("DD")
- SET ISD=Y
- +2 SET Y=DATE
- XECUTE ^DD("DD")
- SET DATE1=Y
- DO NOW^%DTC
- SET Y=%
- XECUTE ^DD("DD")
- SET NOW=Y
- +3 if '$PIECE($GET(^PS(59,+$GET(PSOSITE),1)),"^",28)
- SET TB1=38
- SET TB2=50
- SET TB3=83
- if $PIECE($GET(^PS(59,+$GET(PSOSITE),1)),"^",28)
- SET TB1=54
- SET TB2=66
- SET TB3=102
- PRINT ;
- +1 WRITE !,"***********************************",?TB3
- if $GET(RXRP(RX))
- WRITE "(REPRINT)"
- IF '$GET(RXRP(RX))
- WRITE $PIECE(PS2,"^",2)," ","("_$PIECE(RXY,"^",16)_"/"_$SELECT(+$GET(VRPH):VRPH,1:" ")_")"_" ",$PIECE(NOW,":",1,2)
- +2 WRITE !,"* THIS MEDICATION HAS INDICATED A *",?TB1,"PRESCRIPTION # "_RXN_" HAS",?TB3,RXN," ",DATE1," Fill 1 of ",1+$PIECE(RXY,"^",9)
- +3 WRITE !,"* DRUG ALLERGY *",?TB1,"INDICATED A DRUG ALLERGY:",?TB3,PNM," ",SSNP
- +4 WRITE !,"***********************************"
- +5 SET PSOING(1)=""
- SET PSOING(2)=$GET(DRUG)
- IF $ORDER(^PSRX(RX,"DAI",0))
- Begin DoDot:1
- +6 SET PSOING(3)=" "_"INGREDIENTS:"
- SET ICOUNT=4
- FOR BBBB=0:0
- SET BBBB=$ORDER(^PSRX(RX,"DAI",BBBB))
- if 'BBBB
- QUIT
- SET PSOING(ICOUNT)=" "_$GET(^(BBBB,0))
- SET ICOUNT=ICOUNT+1
- End DoDot:1
- +7 SET (PSAQUIT,PSBQUIT,PSCQUIT)=0
- FOR ICOUNT=1:1
- if $GET(PSCQUIT)
- QUIT
- Begin DoDot:1
- +8 WRITE ?TB1,$GET(PSOING(ICOUNT))
- if '$ORDER(PSOING(ICOUNT))
- SET PSAQUIT=1
- +9 WRITE ?TB3,$SELECT($GET(OSGY(ICOUNT))]"":OSGY(ICOUNT),1:$GET(SGY(ICOUNT))),!
- if '$ORDER(SGY(ICOUNT))
- SET PSBQUIT=1
- +10 IF PSAQUIT
- IF PSBQUIT
- SET PSCQUIT=1
- End DoDot:1
- +11 WRITE !!,?TB1,"THIS PRESCRIPTION WAS ENTERED BY",?TB3,"Qty: ",$GET(QTY)," ",$GET(PHYS)
- +12 WRITE !,?TB1,$GET(TECH),?TB3,"Tech__________RPh__________"
- +13 WRITE !,?TB1,"THIS PRESCRIPTION MAY REQUIRE",?TB3,$GET(DRUG)
- +14 WRITE !,?TB1,"REVIEWING BY A PHARMACIST",?TB3,"Routing: "_$SELECT("W"[$EXTRACT(MW):MW,1:MW_" MAIL")
- +15 WRITE !,?TB3,"Days Supply: ",$GET(DAYS)," Cap: ",$SELECT(PSCAP:"**NON-SFTY**",1:"SAFETY")
- +16 WRITE !,?TB3,"Isd: ",ISD," Exp: ",EXPDT
- +17 WRITE !,?TB3,"Last Fill: ",$GET(PSOLASTF)
- +18 WRITE !,?TB3,"Pat. Stat ",PATST," Clinic: ",PSCLN
- +19 WRITE @IOF
- +20 IF COPIES>0
- GOTO START
- +21 SET COPIES=HARDCOPY
- KILL HARDCOPY
- +22 ;
- STORE ;ALLERGY LABEL PRINT NODE - SHOULD ALWAYS BE ON THE ORIGINAL
- +1 DO NOW^%DTC
- SET NOW=%
- SET PSAA=0
- FOR AAA=0:0
- SET AAA=$ORDER(^PSRX(RX,"L",AAA))
- if 'AAA
- QUIT
- SET PSAA=AAA
- +2 SET PSAA=PSAA+1
- SET ^PSRX(RX,"L",0)="^52.032DA^"_PSAA_"^"_PSAA
- SET ^PSRX(RX,"L",PSAA,0)=NOW_"^"_0_"^Allergy warning label"_$SELECT($GET(RXRP(RX)):" (Reprint)",1:"")_"^"_PDUZ_"^2"
- END ;
- +1 QUIT