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 Dec 13, 2024@01:46:11 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
