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

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.3 KB
Line 
1PSDGSH11 ;BIR/JPW-Review Green Sheet History (cont'd) ; 24 Aug 94
2 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
3SET1 ;
4 I +$P(NODE,"^",2)=12 S PSDDT=$P(NODE1,"^",2) I PSDDT S PSDDT=$$FMTE^XLFDT(PSDDT,"2P")
5 S PSDBY=$P(NODE1,"^") I PSDBY S PSDBY=$P($G(^VA(200,+PSDBY,0)),"^")
6 S PROC=$P(NODE1,"^",2) I PROC S PROC=$$FMTE^XLFDT(PROC,"2P")
7 S ORC=$P(NODE1,"^",3) I ORC S ORC=$P($G(^VA(200,+ORC,0)),"^")
8 S ORCD=$P(NODE1,"^",4) I ORCD S ORCD=$$FMTE^XLFDT(ORCD,"2P")
9 S FILL=$P(NODE1,"^",5) I FILL S FILL=$P($G(^VA(200,+FILL,0)),"^")
10 S REQD=$P(NODE1,"^",6) I REQD S REQD=$$FMTE^XLFDT(REQD,"2P")
11 S REQ=$P(NODE1,"^",7) I REQ S REQ=$P($G(^VA(200,+REQ,0)),"^")
12 S RTECH=$P(NODE1,"^",11) I RTECH S RTECH=$P($G(^VA(200,+RTECH,0)),"^")
13SET1N S RETN=$P(NODE1,"^",10) I RETN S RETN=$P($G(^VA(200,+RETN,0)),"^")
14 S PUDT=$P(NODE1,"^",12) I PUDT S PUDT=$$FMTE^XLFDT(PUDT,"2P")
15 S PUBY=$P(NODE1,"^",13) I PUBY S PUBY=$P($G(^VA(200,+PUBY,0)),"^")
16 S CBY=$P(NODE1,"^",14) I CBY S CBY=$P($G(^VA(200,+CBY,0)),"^")
17 S OTR=$P(NODE1,"^",15)
18 Q
19SET3 ;
20 S STKD=$P(NODE3,"^") I STKD S STKD=$$FMTE^XLFDT(STKD,"2P")
21 S STKQ=+$P(NODE3,"^",2),SREAS=$P(NODE3,"^",3)
22 S DESTD=$P(NODE3,"^",4) I DESTD S DESTD=$$FMTE^XLFDT(DESTD,"2P")
23 S DESTQ=+$P(NODE3,"^",5),DESTH=+$P(NODE3,"^",8),DREAS=$P(NODE3,"^",6)
24 S DESD=$P($G(^PSD(58.86,+DESTH,0)),"^",11),DESDP=$P($G(^(0)),"^",10)
25 I DESD S DESD=$$FMTE^XLFDT(DESD,"2P")
26 I DESDP S DESDP=$P($G(^VA(200,+DESDP,0)),"^")
27 Q
28SET4 ;
29 S EDT=$P(NODE4,"^") I EDT S EDT=$$FMTE^XLFDT(EDT,"2P")
30 S EDPH=$P(NODE4,"^",2) I EDPH S EDPH=$P($G(^VA(200,+EDPH,0)),"^")
31 S EDQTY=+$P(NODE4,"^",3),EDADJ=+$P(NODE4,"^",4),EDMFG=+$P(NODE4,"^",5),EREAS=$P(NODE4,"^",6)
32 Q
33SET5 ;
34 S CANCD=$P(NODE5,"^") I CANCD S CANCD=$$FMTE^XLFDT(CANCD,"2P")
35 S CANCPH=$P(NODE5,"^",2) I CANCPH S CANCPH=$P($G(^VA(200,+CANCPH,0)),"^")
36 S CANCQ=+$P(NODE5,"^",3),CREAS=$P(NODE5,"^",4)
37 Q
38SET7 ;
39 Q:'$D(^PSD(58.81,PSDA,7)) S TRANS=1
40 S CNT=CNT+1
41 S TFRD=+$P(NODE7,"^") I TFRD S TFRD=$$FMTE^XLFDT(TFRD,"2P")
42 S NURSF=+$P(NODE7,"^",2) I NURSF S NURSF=$P($G(^VA(200,+NURSF,0)),"^")
43 S TFRN=+$P(NODE,"^",18) I TFRN S TFRN=$P($G(^PSD(58.8,+TFRN,0)),"^")
44 S TFTD=+$P(NODE7,"^",4) I TFTD S TFTD=$$FMTE^XLFDT(TFTD,"2P")
45 S TFTN=+$P(NODE7,"^",3) I TFTN S TFTN=$P($G(^PSD(58.8,+TFTN,0)),"^")
46 S NURST=+$P(NODE7,"^",5) I NURST S NURST=$P($G(^VA(200,+NURST,0)),"^")
47 S TQTY=+$P(NODE7,"^",7),NEW=+$O(^PSD(58.81,"AE",PSDA,0))
48 S TRN(CNT)=TFRN_"^"_TFRD_"^"_NURSF_"^"_TFTN_"^"_TFTD_"^"_NURST_"^"_TQTY
49 I NEW S PSDA=NEW D SETN
50 Q
51SETN ;
52 Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^(0)
53 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
54 S STAT=+$P(NODE,"^",11),STAT=$P($G(^PSD(58.82,+STAT,0)),"^")
55 S COMP=+$P(NODE,"^",12),COMP=$P($G(^PSD(58.83,+COMP,0)),"^")
56 S CDT=+$P(NODE,"^",19) I CDT S CDT=$$FMTE^XLFDT(CDT,"2P")
57 I $D(^PSD(58.81,PSDA,1)) S NODE1=^(1) D SET1N
58 I $D(^PSD(58.81,PSDA,3)) S NODE3=^(3) D SET3
59 I $D(^PSD(58.81,PSDA,1.5)) S NODE15=^(1.5) D SET15
60 I $D(^PSD(58.81,PSDA,1.6)) S NODE16=^(1.6)
61 ;Q:'$O(^PSD(58.81,"AE",PSDA,0))
62 I $P($G(^PSD(58.81,PSDA,7)),U) S NODE7=^(7) D SET7
63 Q
64SET15 ;
65 S PSDTP=$P(NODE15,"^",2),PSDIP=$P(NODE15,"^",3),PSDIR=$P(NODE15,"^",4)
66 S PSDUZA=$P(NODE15,"^",2)
67 I PSDUZA S PSDUZAN=$P($G(^VA(200,+PSDUZA,0)),"^")
68 I PSDTP S PSDTP=$$FMTE^XLFDT(PSDTP,"2P")
69 I PSDIP S PSDIP=$$FMTE^XLFDT(PSDIP,"2P")
70 I PSDIR S PSDIR=$$FMTE^XLFDT(PSDIR,"2P")
71 Q
Note: See TracBrowser for help on using the repository browser.