source: FOIAVistA/trunk/r/CONTROLLED_SUBSTANCES-PSD/PSDPDR1.m@ 794

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

initial load of FOIAVistA 6/30/08 version

File size: 2.9 KB
Line 
1PSDPDR1 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 03 Mar 98
2 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
3 ;**Y2K compliance** display 4 digit year on va forms
4START ;compile data
5 K ^TMP("PSDRPT",$J)
6 I $D(PSDG) F PSD=0:0 S PSD=$O(PSDG(PSD)) Q:'PSD F PSDN=0:0 S PSDN=$O(^PSI(58.2,PSD,3,PSDN)) Q:'PSDN I $D(^PSD(58.8,PSDN,0)),$P(^(0),"^",2)="N",+$P(^(0),"^",4)=+PSDS S NAOU(PSDN)="",CNT=CNT+1
7 I $D(ALL) F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $D(^PSD(58.8,PSD,0)),$P(^(0),"^",2)="N",$P(^(0),"^",4)=+PSDS S NAOU(+PSD)=""
8 F PSD=0:0 S PSD=$O(^PSD(58.81,"AD",3,PSD)) G:('PSD)&($D(ZTQUEUED)) PRTQUE G:'PSD PRINT^PSDPDR2 F PSDA=0:0 S PSDA=$O(^PSD(58.81,"AD",3,PSD,PSDA)) Q:'PSDA I $D(^PSD(58.81,PSDA,0)) D
9 .S NODE=^PSD(58.81,PSDA,0),PSDN=+$P(NODE,"^",18)
10 .I $D(NAOU(PSDN)) S PSDNA=$S($P($G(^PSD(58.8,PSDN,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDN) D
11 ..S PSDR=+$P(NODE,"^",5),PSDRN=$S($P($G(^PSDRUG(PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDR),STAT=+$P(NODE,"^",11) Q:+$P($G(^PSD(58.81,PSDA,"CS")),"^",3)!(STAT'=3)
12 ..S STATN=$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
13 ..S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
14 ..S COMM=$S($D(^PSD(58.81,PSDA,2,0)):1,1:0),MFG=$P(NODE,"^",13),LOT=$P(NODE,"^",14),EXP=$P(NODE,"^",15),EXPD=""
15 ..;;The next two lines inserted for E3R# 3311 2-9-95.
16 ..S:$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(^(4),"^",7)+$P(^(4),"^",4),FNOTE="*"
17 ..S:'$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(NODE,"^",10)-QTY,FNOTE=""
18 ..I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD
19 ..S NUM=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN")
20 ..S ORD=+$P($G(^PSD(58.81,PSDA,1)),"^",7),ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
21 ..S REQD=$P($G(^PSD(58.81,PSDA,1)),"^",6),REQDT="" I REQD S Y=REQD X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4) S REQDT=$E(REQD,4,5)_"/"_$E(REQD,6,7)_"/"_PSDYR
22 ..S PSDST=$P(NODE,"^",4),PSDDT="" I PSDST S Y=PSDST X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4)
23 ..S PSDDT=$E(PSDST,4,5)_"/"_$E(PSDST,6,7)_"/"_PSDYR
24 ..;;Fnote and Newbal added for E3R# 3311 2-9-95.
25 ..S ^TMP("PSDRPT",$J,PSDNA,NUM)=PSDRN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_NEWBAL_"^"_FNOTE
26 Q
27PRTQUE ;queues print after compile
28 K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDPDR2",ZTDESC="Print Narcotic Disp Report",ZTDTH=$H
29 S (ZTSAVE("^TMP(""PSDRPT"",$J,"),ZTSAVE("PSDS"),ZTSAVE("PSDPT"),ZTSAVE("CNT"),ZTSAVE("PSDCPY"))=""
30 D ^%ZTLOAD K ^TMP("PSDRPT",$J),ZTSK
31END K %,%H,%I,%ZIS,ALL,C,CNT,COPY,COMM,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,EXP,EXPD,EXP1,FLAG,LOT,MFG,NAOU,NEWBAL,NODE,NUM
32 K FNOTE,OK,ORD,ORDN,POP,PSD,PSDA,PSDCPY,PSDDT,PSDEV,PSDG,PSDIO,PSDN,PSDNA,PSDPT,PSDR,PSDRN,PSDS,PSDSN,PSDT,PSDSN,PSDST,PSDYR,QTY,REQD,REQDT,SEL,STAT,STATN,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
33 K ^TMP("PSDRPT",$J) D ^%ZISC
34 S:$D(ZTQUEUED) ZTREQ="@"
35 Q
Note: See TracBrowser for help on using the repository browser.