- PSDTRVR1 ;BIR/JPW-CS Transfer Vaults Report (cont'd) ; 4 Aug 94
- ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- START ;compile data
- K ^TMP("PSDTRVR",$J) S PSDOUT=0
- F JJ=0:0 S JJ=$O(SITE(JJ)) Q:'JJ F TYP="M","S" F PSDS=0:0 S PSDS=$O(^PSD(58.8,"ASITE",+JJ,TYP,PSDS)) Q:'PSDS S PSDS(PSDS)=""
- F PSDS=0:0 S PSDS=$O(PSDS(PSDS)) Q:'PSDS F PSD=PSDSD:0 S PSD=$O(^PSD(58.81,"ACT",PSD)) Q:'PSD!(PSD>PSDED) F PSDR=0:0 S PSDR=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR)) Q:'PSDR D
- .F PSDA=0:0 S PSDA=$O(^PSD(58.81,"ACT",PSD,PSDS,PSDR,16,PSDA)) Q:'PSDA D
- ..Q:'$D(^PSD(58.81,PSDA,0)) S NODE=^PSD(58.81,PSDA,0)
- ..S PSDRN=$S($P($G(^PSDRUG(+PSDR,0)),"^")]"":$P(^(0),"^"),1:"ZZ/UNKNOWN")
- ..S PSDSN=$S($P($G(^PSD(58.8,+PSDS,0)),"^")]"":$P(^(0),"^"),1:"ZZ/UNKNOWN")
- ..S QTY=$P(NODE,"^",6),PHARM=$P(NODE,"^",7),PHARMN=$S($P($G(^VA(200,+PHARM,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
- ..S ^TMP("PSDTRVR",$J,PSDSN,PSDRN,PSD)=QTY_"^"_PHARMN
- PRINT ;print transfer between vaults by date
- S (PG,PSDOUT)=0
- K LN S $P(LN,"-",80)="" D NOW^%DTC S Y=+$E(%,1,12) X ^DD("DD") S RPDT=Y
- I '$D(^TMP("PSDTRVR",$J)) D HDR W !!,?10,"**** NO TRANSFER BETWEEN VAULTS DATA FOR THIS REPORT ****" G DONE
- S JJ="" F S JJ=$O(^TMP("PSDTRVR",$J,JJ)) Q:JJ=""!(PSDOUT) D HDR S KK="" F S KK=$O(^TMP("PSDTRVR",$J,JJ,KK)) Q:KK=""!(PSDOUT) D:$Y+9>IOSL HDR Q:PSDOUT W !,?2,"=> ",KK,!! F LL=0:0 S LL=$O(^TMP("PSDTRVR",$J,JJ,KK,LL)) Q:'LL!(PSDOUT) D
- .D:$Y+8>IOSL HDR Q:PSDOUT
- .S NODE=^TMP("PSDTRVR",$J,JJ,KK,LL),QTY=$P(NODE,"^")
- .S Y=LL X ^DD("DD") S PSDT=Y
- .W PSDT,?25,$J(QTY,8),?40,$P(NODE,"^",2),!
- .W:ASK !,?5,"Transferred/Received By: _______________________________________________",!!
- DONE I $E(IOST)'="C" W @IOF
- I $E(IOST,1,2)="C-",'PSDOUT W ! K DIR,DIRUT S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu" D ^DIR K DIR
- END ;
- K %,%DT,%H,%I,%ZIS,ASK,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,JJ,KK,LL,LN,NODE,OK
- K PG,PHARM,PHARMN,POP,PSD,PSDA,PSDATE,PSDED,PSDOUT,PSDR,PSDRN,PSDS,PSDSD,PSDSN,PSDT,QTY,RPDT,SITE,SITEN,TYP,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- K ^TMP("PSDTRVR",$J) D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
- Q
- HDR ;header for log
- I $E(IOST,1,2)="C-",PG W ! K DA,DIR S DIR(0)="E" D ^DIR K DIR I 'Y S PSDOUT=1 Q
- S PG=PG+1 W:$Y @IOF W !,?15,"TRANSFER CS DRUGS BETWEEN DISP SITES REPORT",?70,"Page: ",PG
- W !,?15,"TRANSACTIONS FOR PERIOD ",$P(PSDATE,"^")," TO ",$P(PSDATE,"^",2)
- W:$G(JJ)]"" !,?15,"DISPENSING SITE: ",JJ
- W !,?15,"PRINTED ",RPDT,!!,?2,"=> DRUG",!!,"DATE/TIME TRANSFERRED",?28,"QUANTITY",?40,"TRANSFERRED BY",!,LN,!
- Q
- PSDTRVR1 ;BIR/JPW-CS Transfer Vaults Report (cont'd) ; 4 Aug 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
- START ;compile data
- +1 KILL ^TMP("PSDTRVR",$JOB)
- SET PSDOUT=0
- +2 FOR JJ=0:0
- SET JJ=$ORDER(SITE(JJ))
- IF 'JJ
- QUIT
- FOR TYP="M","S"
- FOR PSDS=0:0
- SET PSDS=$ORDER(^PSD(58.8,"ASITE",+JJ,TYP,PSDS))
- IF 'PSDS
- QUIT
- SET PSDS(PSDS)=""
- +3 FOR PSDS=0:0
- SET PSDS=$ORDER(PSDS(PSDS))
- IF 'PSDS
- QUIT
- FOR PSD=PSDSD:0
- SET PSD=$ORDER(^PSD(58.81,"ACT",PSD))
- IF 'PSD!(PSD>PSDED)
- QUIT
- FOR PSDR=0:0
- SET PSDR=$ORDER(^PSD(58.81,"ACT",PSD,PSDS,PSDR))
- IF 'PSDR
- QUIT
- Begin DoDot:1
- +4 FOR PSDA=0:0
- SET PSDA=$ORDER(^PSD(58.81,"ACT",PSD,PSDS,PSDR,16,PSDA))
- IF 'PSDA
- QUIT
- Begin DoDot:2
- +5 IF '$DATA(^PSD(58.81,PSDA,0))
- QUIT
- SET NODE=^PSD(58.81,PSDA,0)
- +6 SET PSDRN=$SELECT($PIECE($GET(^PSDRUG(+PSDR,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/UNKNOWN")
- +7 SET PSDSN=$SELECT($PIECE($GET(^PSD(58.8,+PSDS,0)),"^")]"":$PIECE(^(0),"^"),1:"ZZ/UNKNOWN")
- +8 SET QTY=$PIECE(NODE,"^",6)
- SET PHARM=$PIECE(NODE,"^",7)
- SET PHARMN=$SELECT($PIECE($GET(^VA(200,+PHARM,0)),"^")]"":$PIECE(^(0),"^"),1:"UNKNOWN")
- +9 SET ^TMP("PSDTRVR",$JOB,PSDSN,PSDRN,PSD)=QTY_"^"_PHARMN
- End DoDot:2
- End DoDot:1
- PRINT ;print transfer between vaults by date
- +1 SET (PG,PSDOUT)=0
- +2 KILL LN
- SET $PIECE(LN,"-",80)=""
- DO NOW^%DTC
- SET Y=+$EXTRACT(%,1,12)
- XECUTE ^DD("DD")
- SET RPDT=Y
- +3 IF '$DATA(^TMP("PSDTRVR",$JOB))
- DO HDR
- WRITE !!,?10,"**** NO TRANSFER BETWEEN VAULTS DATA FOR THIS REPORT ****"
- GOTO DONE
- +4 SET JJ=""
- FOR
- SET JJ=$ORDER(^TMP("PSDTRVR",$JOB,JJ))
- IF JJ=""!(PSDOUT)
- QUIT
- DO HDR
- SET KK=""
- FOR
- SET KK=$ORDER(^TMP("PSDTRVR",$JOB,JJ,KK))
- IF KK=""!(PSDOUT)
- QUIT
- IF $Y+9>IOSL
- DO HDR
- IF PSDOUT
- QUIT
- WRITE !,?2,"=> ",KK,!!
- FOR LL=0:0
- SET LL=$ORDER(^TMP("PSDTRVR",$JOB,JJ,KK,LL))
- IF 'LL!(PSDOUT)
- QUIT
- Begin DoDot:1
- +5 IF $Y+8>IOSL
- DO HDR
- IF PSDOUT
- QUIT
- +6 SET NODE=^TMP("PSDTRVR",$JOB,JJ,KK,LL)
- SET QTY=$PIECE(NODE,"^")
- +7 SET Y=LL
- XECUTE ^DD("DD")
- SET PSDT=Y
- +8 WRITE PSDT,?25,$JUSTIFY(QTY,8),?40,$PIECE(NODE,"^",2),!
- +9 IF ASK
- WRITE !,?5,"Transferred/Received By: _______________________________________________",!!
- End DoDot:1
- DONE IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF 'PSDOUT
- WRITE !
- KILL DIR,DIRUT
- SET DIR(0)="EA"
- SET DIR("A")="END OF REPORT! Press <RET> to return to the menu"
- DO ^DIR
- KILL DIR
- END ;
- +1 KILL %,%DT,%H,%I,%ZIS,ASK,CNT,DA,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,JJ,KK,LL,LN,NODE,OK
- +2 KILL PG,PHARM,PHARMN,POP,PSD,PSDA,PSDATE,PSDED,PSDOUT,PSDR,PSDRN,PSDS,PSDSD,PSDSN,PSDT,QTY,RPDT,SITE,SITEN,TYP,X,Y,ZTDESC,ZTDTH,ZTRTN,ZTSAVE,ZTSK
- +3 KILL ^TMP("PSDTRVR",$JOB)
- DO ^%ZISC
- IF $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 QUIT
- HDR ;header for log
- +1 IF $EXTRACT(IOST,1,2)="C-"
- IF PG
- WRITE !
- KILL DA,DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- IF 'Y
- SET PSDOUT=1
- QUIT
- +2 SET PG=PG+1
- IF $Y
- WRITE @IOF
- WRITE !,?15,"TRANSFER CS DRUGS BETWEEN DISP SITES REPORT",?70,"Page: ",PG
- +3 WRITE !,?15,"TRANSACTIONS FOR PERIOD ",$PIECE(PSDATE,"^")," TO ",$PIECE(PSDATE,"^",2)
- +4 IF $GET(JJ)]""
- WRITE !,?15,"DISPENSING SITE: ",JJ
- +5 WRITE !,?15,"PRINTED ",RPDT,!!,?2,"=> DRUG",!!,"DATE/TIME TRANSFERRED",?28,"QUANTITY",?40,"TRANSFERRED BY",!,LN,!
- +6 QUIT
