- PSDPDR1 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 03 Mar 98
- ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- ;**Y2K compliance** display 4 digit year on va forms
- START ;compile data
- K ^TMP("PSDRPT",$J)
- 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
- 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)=""
- 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
- .S NODE=^PSD(58.81,PSDA,0),PSDN=+$P(NODE,"^",18)
- .I $D(NAOU(PSDN)) S PSDNA=$S($P($G(^PSD(58.8,PSDN,0)),"^")]"":$P(^(0),"^"),1:"ZZ/"_PSDN) D
- ..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)
- ..S STATN=$S($P($G(^PSD(58.82,STAT,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- ..S QTY=$P(NODE,"^",6) I $D(^PSD(58.81,PSDA,4)),+$P(^(4),"^",3) S QTY=$P(^(4),"^",3)
- ..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=""
- ..;;The next two lines inserted for E3R# 3311 2-9-95.
- ..S:$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(^(4),"^",7)+$P(^(4),"^",4),FNOTE="*"
- ..S:'$D(^PSD(58.81,PSDA,4)) NEWBAL=$P(NODE,"^",10)-QTY,FNOTE=""
- ..I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3) S EXP=EXPD
- ..S NUM=$S($P(NODE,"^",17)]"":$P(NODE,"^",17),1:"UNKNOWN")
- ..S ORD=+$P($G(^PSD(58.81,PSDA,1)),"^",7),ORDN=$S($P($G(^VA(200,ORD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- ..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
- ..S PSDST=$P(NODE,"^",4),PSDDT="" I PSDST S Y=PSDST X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4)
- ..S PSDDT=$E(PSDST,4,5)_"/"_$E(PSDST,6,7)_"/"_PSDYR
- ..;;Fnote and Newbal added for E3R# 3311 2-9-95.
- ..S ^TMP("PSDRPT",$J,PSDNA,NUM)=PSDRN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_NEWBAL_"^"_FNOTE
- Q
- PRTQUE ;queues print after compile
- K ZTSAVE,ZTIO S ZTIO=PSDIO,ZTRTN="PRINT^PSDPDR2",ZTDESC="Print Narcotic Disp Report",ZTDTH=$H
- S (ZTSAVE("^TMP(""PSDRPT"",$J,"),ZTSAVE("PSDS"),ZTSAVE("PSDPT"),ZTSAVE("CNT"),ZTSAVE("PSDCPY"))=""
- D ^%ZTLOAD K ^TMP("PSDRPT",$J),ZTSK
- END 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
- 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
- K ^TMP("PSDRPT",$J) D ^%ZISC
- S:$D(ZTQUEUED) ZTREQ="@"
- Q
- PSDPDR1 ;BIR/BJW-Narc Disp/Rec Report (VA FORM 10-2321) (cont'd) ; 03 Mar 98
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**8**;13 Feb 97
- +2 ;**Y2K compliance** display 4 digit year on va forms
- START ;compile data
- +1 KILL ^TMP("PSDRPT",$JOB)
- +2 IF $DATA(PSDG)
- FOR PSD=0:0
- SET PSD=$ORDER(PSDG(PSD))
- IF 'PSD
- QUIT
- FOR PSDN=0:0
- SET PSDN=$ORDER(^PSI(58.2,PSD,3,PSDN))
- IF 'PSDN
- QUIT
- IF $DATA(^PSD(58.8,PSDN,0))
- IF $PIECE(^(0),"^",2)="N"
- IF +$PIECE(^(0),"^",4)=+PSDS
- SET NAOU(PSDN)=""
- SET CNT=CNT+1
- +3 IF $DATA(ALL)
- FOR PSD=0:0
- SET PSD=$ORDER(^PSD(58.8,PSD))
- IF 'PSD
- QUIT
- IF $DATA(^PSD(58.8,PSD,0))
- IF $PIECE(^(0),"^",2)="N"
- IF $PIECE(^(0),"^",4)=+PSDS
- SET NAOU(+PSD)=""
- +4 FOR PSD=0:0
- SET PSD=$ORDER(^PSD(58.81,"AD",3,PSD))
- IF ('PSD)&($DATA(ZTQUEUED))
- GOTO PRTQUE
- IF 'PSD
- GOTO PRINT^PSDPDR2
- FOR PSDA=0:0
- SET PSDA=$ORDER(^PSD(58.81,"AD",3,PSD,PSDA))
- IF 'PSDA
- QUIT
- IF $DATA(^PSD(58.81,PSDA,0))
- Begin DoDot:1
- +5 SET NODE=^PSD(58.81,PSDA,0)
- SET PSDN=+$PIECE(NODE,"^",18)
- +6 IF $DATA(NAOU(PSDN))
- SET PSDNA=$SELECT($PIECE($GET(^PSD(58.8,PSDN,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDN)
- Begin DoDot:2
- +7 SET PSDR=+$PIECE(NODE,"^",5)
- SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/"_PSDR)
- SET STAT=+$PIECE(NODE,"^",11)
- IF +$PIECE($GET(^PSD(58.81,PSDA,"CS")),"^",3)!(STAT'=3)
- QUIT
- +8 SET STATN=$SELECT($PIECE($GET(^PSD(58.82,STAT,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +9 SET QTY=$PIECE(NODE,"^",6)
- IF $DATA(^PSD(58.81,PSDA,4))
- IF +$PIECE(^(4),"^",3)
- SET QTY=$PIECE(^(4),"^",3)
- +10 SET COMM=$SELECT($DATA(^PSD(58.81,PSDA,2,0)):1,1:0)
- SET MFG=$PIECE(NODE,"^",13)
- SET LOT=$PIECE(NODE,"^",14)
- SET EXP=$PIECE(NODE,"^",15)
- SET EXPD=""
- +11 ;;The next two lines inserted for E3R# 3311 2-9-95.
- +12 IF $DATA(^PSD(58.81,PSDA,4))
- SET NEWBAL=$PIECE(^(4),"^",7)+$PIECE(^(4),"^",4)
- SET FNOTE="*"
- +13 IF '$DATA(^PSD(58.81,PSDA,4))
- SET NEWBAL=$PIECE(NODE,"^",10)-QTY
- SET FNOTE=""
- +14 IF EXP
- SET (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D")
- IF '$PIECE(EXP1,"/",2)
- SET EXPD=$PIECE(EXP1,"/")_"/"_$PIECE(EXP1,"/",3)
- SET EXP=EXPD
- +15 SET NUM=$SELECT($PIECE(NODE,"^",17)]"":$PIECE(NODE,"^",17),1:"UNKNOWN")
- +16 SET ORD=+$PIECE($GET(^PSD(58.81,PSDA,1)),"^",7)
- SET ORDN=$SELECT($PIECE($GET(^VA(200,ORD,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +17 SET REQD=$PIECE($GET(^PSD(58.81,PSDA,1)),"^",6)
- SET REQDT=""
- IF REQD
- SET Y=REQD
- XECUTE ^DD("DD")
- SET PSDYR=$PIECE(Y,",",2)
- SET PSDYR=$EXTRACT(PSDYR,1,4)
- SET REQDT=$EXTRACT(REQD,4,5)_"/"_$EXTRACT(REQD,6,7)_"/"_PSDYR
- +18 SET PSDST=$PIECE(NODE,"^",4)
- SET PSDDT=""
- IF PSDST
- SET Y=PSDST
- XECUTE ^DD("DD")
- SET PSDYR=$PIECE(Y,",",2)
- SET PSDYR=$EXTRACT(PSDYR,1,4)
- +19 SET PSDDT=$EXTRACT(PSDST,4,5)_"/"_$EXTRACT(PSDST,6,7)_"/"_PSDYR
- +20 ;;Fnote and Newbal added for E3R# 3311 2-9-95.
- +21 SET ^TMP("PSDRPT",$JOB,PSDNA,NUM)=PSDRN_"^"_QTY_FNOTE_"^"_PSDDT_"^"_REQDT_"^"_ORDN_"^"_MFG_"^"_LOT_"^"_EXPD_"^"_COMM_"^"_PSDA_"^"_NEWBAL_"^"_FNOTE
- End DoDot:2
- End DoDot:1
- +22 QUIT
- PRTQUE ;queues print after compile
- +1 KILL ZTSAVE,ZTIO
- SET ZTIO=PSDIO
- SET ZTRTN="PRINT^PSDPDR2"
- SET ZTDESC="Print Narcotic Disp Report"
- SET ZTDTH=$HOROLOG
- +2 SET (ZTSAVE("^TMP(""PSDRPT"",$J,"),ZTSAVE("PSDS"),ZTSAVE("PSDPT"),ZTSAVE("CNT"),ZTSAVE("PSDCPY"))=""
- +3 DO ^%ZTLOAD
- KILL ^TMP("PSDRPT",$JOB),ZTSK
- END KILL %,%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
- +1 KILL 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
- +2 KILL ^TMP("PSDRPT",$JOB)
- DO ^%ZISC
- +3 IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
