source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDGSH11.m@ 674

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