- PSDGSH11 ;BIR/JPW-Review Green Sheet History (cont'd) ; 24 Aug 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SET1 ;
- I +$P(NODE,"^",2)=12 S PSDDT=$P(NODE1,"^",2) I PSDDT S PSDDT=$$FMTE^XLFDT(PSDDT,"2P")
- S PSDBY=$P(NODE1,"^") I PSDBY S PSDBY=$P($G(^VA(200,+PSDBY,0)),"^")
- S PROC=$P(NODE1,"^",2) I PROC S PROC=$$FMTE^XLFDT(PROC,"2P")
- S ORC=$P(NODE1,"^",3) I ORC S ORC=$P($G(^VA(200,+ORC,0)),"^")
- S ORCD=$P(NODE1,"^",4) I ORCD S ORCD=$$FMTE^XLFDT(ORCD,"2P")
- S FILL=$P(NODE1,"^",5) I FILL S FILL=$P($G(^VA(200,+FILL,0)),"^")
- S REQD=$P(NODE1,"^",6) I REQD S REQD=$$FMTE^XLFDT(REQD,"2P")
- S REQ=$P(NODE1,"^",7) I REQ S REQ=$P($G(^VA(200,+REQ,0)),"^")
- S RTECH=$P(NODE1,"^",11) I RTECH S RTECH=$P($G(^VA(200,+RTECH,0)),"^")
- SET1N S RETN=$P(NODE1,"^",10) I RETN S RETN=$P($G(^VA(200,+RETN,0)),"^")
- S PUDT=$P(NODE1,"^",12) I PUDT S PUDT=$$FMTE^XLFDT(PUDT,"2P")
- S PUBY=$P(NODE1,"^",13) I PUBY S PUBY=$P($G(^VA(200,+PUBY,0)),"^")
- S CBY=$P(NODE1,"^",14) I CBY S CBY=$P($G(^VA(200,+CBY,0)),"^")
- S OTR=$P(NODE1,"^",15)
- Q
- SET3 ;
- S STKD=$P(NODE3,"^") I STKD S STKD=$$FMTE^XLFDT(STKD,"2P")
- S STKQ=+$P(NODE3,"^",2),SREAS=$P(NODE3,"^",3)
- S DESTD=$P(NODE3,"^",4) I DESTD S DESTD=$$FMTE^XLFDT(DESTD,"2P")
- S DESTQ=+$P(NODE3,"^",5),DESTH=+$P(NODE3,"^",8),DREAS=$P(NODE3,"^",6)
- S DESD=$P($G(^PSD(58.86,+DESTH,0)),"^",11),DESDP=$P($G(^(0)),"^",10)
- I DESD S DESD=$$FMTE^XLFDT(DESD,"2P")
- I DESDP S DESDP=$P($G(^VA(200,+DESDP,0)),"^")
- Q
- SET4 ;
- S EDT=$P(NODE4,"^") I EDT S EDT=$$FMTE^XLFDT(EDT,"2P")
- S EDPH=$P(NODE4,"^",2) I EDPH S EDPH=$P($G(^VA(200,+EDPH,0)),"^")
- S EDQTY=+$P(NODE4,"^",3),EDADJ=+$P(NODE4,"^",4),EDMFG=+$P(NODE4,"^",5),EREAS=$P(NODE4,"^",6)
- Q
- SET5 ;
- S CANCD=$P(NODE5,"^") I CANCD S CANCD=$$FMTE^XLFDT(CANCD,"2P")
- S CANCPH=$P(NODE5,"^",2) I CANCPH S CANCPH=$P($G(^VA(200,+CANCPH,0)),"^")
- S CANCQ=+$P(NODE5,"^",3),CREAS=$P(NODE5,"^",4)
- Q
- SET7 ;
- Q:'$D(^PSD(58.81,PSDA,7)) S TRANS=1
- S CNT=CNT+1
- S TFRD=+$P(NODE7,"^") I TFRD S TFRD=$$FMTE^XLFDT(TFRD,"2P")
- S NURSF=+$P(NODE7,"^",2) I NURSF S NURSF=$P($G(^VA(200,+NURSF,0)),"^")
- S TFRN=+$P(NODE,"^",18) I TFRN S TFRN=$P($G(^PSD(58.8,+TFRN,0)),"^")
- S TFTD=+$P(NODE7,"^",4) I TFTD S TFTD=$$FMTE^XLFDT(TFTD,"2P")
- S TFTN=+$P(NODE7,"^",3) I TFTN S TFTN=$P($G(^PSD(58.8,+TFTN,0)),"^")
- S NURST=+$P(NODE7,"^",5) I NURST S NURST=$P($G(^VA(200,+NURST,0)),"^")
- S TQTY=+$P(NODE7,"^",7),NEW=+$O(^PSD(58.81,"AE",PSDA,0))
- S TRN(CNT)=TFRN_"^"_TFRD_"^"_NURSF_"^"_TFTN_"^"_TFTD_"^"_NURST_"^"_TQTY
- I NEW S PSDA=NEW D SETN
- Q
- SETN ;
- Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^(0)
- S TFTN=+$P(NODE,"^",18) I TFTN S TFTN=$P($G(^PSD(58.8,+TFTN,0)),"^") S:$P(TRN(CNT),"^",4)'=TFTN $P(TRN(CNT),"^",4)=TFTN
- S STAT=+$P(NODE,"^",11),STAT=$P($G(^PSD(58.82,+STAT,0)),"^")
- S COMP=+$P(NODE,"^",12),COMP=$P($G(^PSD(58.83,+COMP,0)),"^")
- S CDT=+$P(NODE,"^",19) I CDT S CDT=$$FMTE^XLFDT(CDT,"2P")
- I $D(^PSD(58.81,PSDA,1)) S NODE1=^(1) D SET1N
- I $D(^PSD(58.81,PSDA,3)) S NODE3=^(3) D SET3
- I $D(^PSD(58.81,PSDA,1.5)) S NODE15=^(1.5) D SET15
- I $D(^PSD(58.81,PSDA,1.6)) S NODE16=^(1.6)
- ;Q:'$O(^PSD(58.81,"AE",PSDA,0))
- I $P($G(^PSD(58.81,PSDA,7)),U) S NODE7=^(7) D SET7
- Q
- SET15 ;
- S PSDTP=$P(NODE15,"^",2),PSDIP=$P(NODE15,"^",3),PSDIR=$P(NODE15,"^",4)
- S PSDUZA=$P(NODE15,"^",2)
- I PSDUZA S PSDUZAN=$P($G(^VA(200,+PSDUZA,0)),"^")
- I PSDTP S PSDTP=$$FMTE^XLFDT(PSDTP,"2P")
- I PSDIP S PSDIP=$$FMTE^XLFDT(PSDIP,"2P")
- I PSDIR S PSDIR=$$FMTE^XLFDT(PSDIR,"2P")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDGSH11 3462 printed Feb 18, 2025@23:12:36 Page 2
- PSDGSH11 ;BIR/JPW-Review Green Sheet History (cont'd) ; 24 Aug 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- SET1 ;
- +1 IF +$PIECE(NODE,"^",2)=12
- SET PSDDT=$PIECE(NODE1,"^",2)
- IF PSDDT
- SET PSDDT=$$FMTE^XLFDT(PSDDT,"2P")
- +2 SET PSDBY=$PIECE(NODE1,"^")
- IF PSDBY
- SET PSDBY=$PIECE($GET(^VA(200,+PSDBY,0)),"^")
- +3 SET PROC=$PIECE(NODE1,"^",2)
- IF PROC
- SET PROC=$$FMTE^XLFDT(PROC,"2P")
- +4 SET ORC=$PIECE(NODE1,"^",3)
- IF ORC
- SET ORC=$PIECE($GET(^VA(200,+ORC,0)),"^")
- +5 SET ORCD=$PIECE(NODE1,"^",4)
- IF ORCD
- SET ORCD=$$FMTE^XLFDT(ORCD,"2P")
- +6 SET FILL=$PIECE(NODE1,"^",5)
- IF FILL
- SET FILL=$PIECE($GET(^VA(200,+FILL,0)),"^")
- +7 SET REQD=$PIECE(NODE1,"^",6)
- IF REQD
- SET REQD=$$FMTE^XLFDT(REQD,"2P")
- +8 SET REQ=$PIECE(NODE1,"^",7)
- IF REQ
- SET REQ=$PIECE($GET(^VA(200,+REQ,0)),"^")
- +9 SET RTECH=$PIECE(NODE1,"^",11)
- IF RTECH
- SET RTECH=$PIECE($GET(^VA(200,+RTECH,0)),"^")
- SET1N SET RETN=$PIECE(NODE1,"^",10)
- IF RETN
- SET RETN=$PIECE($GET(^VA(200,+RETN,0)),"^")
- +1 SET PUDT=$PIECE(NODE1,"^",12)
- IF PUDT
- SET PUDT=$$FMTE^XLFDT(PUDT,"2P")
- +2 SET PUBY=$PIECE(NODE1,"^",13)
- IF PUBY
- SET PUBY=$PIECE($GET(^VA(200,+PUBY,0)),"^")
- +3 SET CBY=$PIECE(NODE1,"^",14)
- IF CBY
- SET CBY=$PIECE($GET(^VA(200,+CBY,0)),"^")
- +4 SET OTR=$PIECE(NODE1,"^",15)
- +5 QUIT
- SET3 ;
- +1 SET STKD=$PIECE(NODE3,"^")
- IF STKD
- SET STKD=$$FMTE^XLFDT(STKD,"2P")
- +2 SET STKQ=+$PIECE(NODE3,"^",2)
- SET SREAS=$PIECE(NODE3,"^",3)
- +3 SET DESTD=$PIECE(NODE3,"^",4)
- IF DESTD
- SET DESTD=$$FMTE^XLFDT(DESTD,"2P")
- +4 SET DESTQ=+$PIECE(NODE3,"^",5)
- SET DESTH=+$PIECE(NODE3,"^",8)
- SET DREAS=$PIECE(NODE3,"^",6)
- +5 SET DESD=$PIECE($GET(^PSD(58.86,+DESTH,0)),"^",11)
- SET DESDP=$PIECE($GET(^(0)),"^",10)
- +6 IF DESD
- SET DESD=$$FMTE^XLFDT(DESD,"2P")
- +7 IF DESDP
- SET DESDP=$PIECE($GET(^VA(200,+DESDP,0)),"^")
- +8 QUIT
- SET4 ;
- +1 SET EDT=$PIECE(NODE4,"^")
- IF EDT
- SET EDT=$$FMTE^XLFDT(EDT,"2P")
- +2 SET EDPH=$PIECE(NODE4,"^",2)
- IF EDPH
- SET EDPH=$PIECE($GET(^VA(200,+EDPH,0)),"^")
- +3 SET EDQTY=+$PIECE(NODE4,"^",3)
- SET EDADJ=+$PIECE(NODE4,"^",4)
- SET EDMFG=+$PIECE(NODE4,"^",5)
- SET EREAS=$PIECE(NODE4,"^",6)
- +4 QUIT
- SET5 ;
- +1 SET CANCD=$PIECE(NODE5,"^")
- IF CANCD
- SET CANCD=$$FMTE^XLFDT(CANCD,"2P")
- +2 SET CANCPH=$PIECE(NODE5,"^",2)
- IF CANCPH
- SET CANCPH=$PIECE($GET(^VA(200,+CANCPH,0)),"^")
- +3 SET CANCQ=+$PIECE(NODE5,"^",3)
- SET CREAS=$PIECE(NODE5,"^",4)
- +4 QUIT
- SET7 ;
- +1 if '$DATA(^PSD(58.81,PSDA,7))
- QUIT
- SET TRANS=1
- +2 SET CNT=CNT+1
- +3 SET TFRD=+$PIECE(NODE7,"^")
- IF TFRD
- SET TFRD=$$FMTE^XLFDT(TFRD,"2P")
- +4 SET NURSF=+$PIECE(NODE7,"^",2)
- IF NURSF
- SET NURSF=$PIECE($GET(^VA(200,+NURSF,0)),"^")
- +5 SET TFRN=+$PIECE(NODE,"^",18)
- IF TFRN
- SET TFRN=$PIECE($GET(^PSD(58.8,+TFRN,0)),"^")
- +6 SET TFTD=+$PIECE(NODE7,"^",4)
- IF TFTD
- SET TFTD=$$FMTE^XLFDT(TFTD,"2P")
- +7 SET TFTN=+$PIECE(NODE7,"^",3)
- IF TFTN
- SET TFTN=$PIECE($GET(^PSD(58.8,+TFTN,0)),"^")
- +8 SET NURST=+$PIECE(NODE7,"^",5)
- IF NURST
- SET NURST=$PIECE($GET(^VA(200,+NURST,0)),"^")
- +9 SET TQTY=+$PIECE(NODE7,"^",7)
- SET NEW=+$ORDER(^PSD(58.81,"AE",PSDA,0))
- +10 SET TRN(CNT)=TFRN_"^"_TFRD_"^"_NURSF_"^"_TFTN_"^"_TFTD_"^"_NURST_"^"_TQTY
- +11 IF NEW
- SET PSDA=NEW
- DO SETN
- +12 QUIT
- SETN ;
- +1 if '$DATA(^PSD(58.81,PSDA,0))
- QUIT
- SET NODE=^(0)
- +2 SET TFTN=+$PIECE(NODE,"^",18)
- IF TFTN
- SET TFTN=$PIECE($GET(^PSD(58.8,+TFTN,0)),"^")
- if $PIECE(TRN(CNT),"^",4)'=TFTN
- SET $PIECE(TRN(CNT),"^",4)=TFTN
- +3 SET STAT=+$PIECE(NODE,"^",11)
- SET STAT=$PIECE($GET(^PSD(58.82,+STAT,0)),"^")
- +4 SET COMP=+$PIECE(NODE,"^",12)
- SET COMP=$PIECE($GET(^PSD(58.83,+COMP,0)),"^")
- +5 SET CDT=+$PIECE(NODE,"^",19)
- IF CDT
- SET CDT=$$FMTE^XLFDT(CDT,"2P")
- +6 IF $DATA(^PSD(58.81,PSDA,1))
- SET NODE1=^(1)
- DO SET1N
- +7 IF $DATA(^PSD(58.81,PSDA,3))
- SET NODE3=^(3)
- DO SET3
- +8 IF $DATA(^PSD(58.81,PSDA,1.5))
- SET NODE15=^(1.5)
- DO SET15
- +9 IF $DATA(^PSD(58.81,PSDA,1.6))
- SET NODE16=^(1.6)
- +10 ;Q:'$O(^PSD(58.81,"AE",PSDA,0))
- +11 IF $PIECE($GET(^PSD(58.81,PSDA,7)),U)
- SET NODE7=^(7)
- DO SET7
- +12 QUIT
- SET15 ;
- +1 SET PSDTP=$PIECE(NODE15,"^",2)
- SET PSDIP=$PIECE(NODE15,"^",3)
- SET PSDIR=$PIECE(NODE15,"^",4)
- +2 SET PSDUZA=$PIECE(NODE15,"^",2)
- +3 IF PSDUZA
- SET PSDUZAN=$PIECE($GET(^VA(200,+PSDUZA,0)),"^")
- +4 IF PSDTP
- SET PSDTP=$$FMTE^XLFDT(PSDTP,"2P")
- +5 IF PSDIP
- SET PSDIP=$$FMTE^XLFDT(PSDIP,"2P")
- +6 IF PSDIR
- SET PSDIR=$$FMTE^XLFDT(PSDIR,"2P")
- +7 QUIT