- PSADAI ;BIR/LTL/,JMB/PDW-Drug Balances by Location ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15,53**; 10/24/97
- ;
- ;Reference to ^PS(59.4 are covered by IA #2505
- ;References to ^PSDRUG( are covered by IA #2095
- ;References to ^PRCP( are covered by IA #214
- ;References to ^PS(59 are covered by IA #212
- ;
- LOC S (PSACNT,PSAOUT)=0 D ^PSAUTL3 G:PSAOUT EXIT1
- S PSACNT=0,PSACHK=$O(PSALOC(""))
- I PSACHK="",'PSALOC W !,"There are no active pharmacy locations." G EXIT1
- I PSACHK'="",$G(PSASEL)="",PSALOC W !!,PSALOCN
- ;
- DEVICE W ! K IO("Q") S %ZIS="Q" D ^%ZIS I POP S DTOUT=1,Y=-1 W !,"No Device was selected or output printed." G EXIT1
- I $D(IO("Q")) S ZTRTN="START^PSADAI",ZTDESC="Drug Accountability - Drug Location Report",ZTSAVE("PSALOC(")="" D ^%ZTLOAD,HOME^%ZIS S Y=1 G EXIT1
- START S PSAOUT=0,PSALOCN="",$P(PSASLN,"-",80)=""
- S PSARPDT=$E($$HTFM^XLFDT($H),1,12),PSADT=$P(PSARPDT,".")
- S PSARPDT=$E(PSADT,4,5)_"/"_$E(PSADT,6,7)_"/"_$E(PSADT,2,3)_"@"_$P(PSARPDT,".",2)
- F S PSALOCN=$O(PSALOC(PSALOCN)) Q:PSALOCN="" D Q:PSAOUT
- .S PSAIEN=0 F S PSAIEN=+$O(PSALOC(PSALOCN,PSAIEN)) Q:'PSAIEN D Q:PSAOUT
- ..S PSAISIT=+$P(PSALOC(PSALOCN,PSAIEN),"^"),PSAOSIT=+$P(PSALOC(PSALOCN,PSAIEN),"^",2)
- ..S PSAISITN=$S($P($G(^PS(59.4,PSAISIT,0)),"^")'="":$P($G(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN")
- ..S PSAOSITN=$S($P($G(^PS(59,PSAOSIT,0)),"^")'="":$P($G(^PS(59,PSAOSIT,0)),"^"),1:"UNKNOWN")
- ..S PSASITES=$S(PSAISIT&(PSAOSIT):PSAISITN_" (IP) "_PSAOSITN_" (OP)",PSAISIT:PSAISITN_" (IP)",1:PSAOSITN_" (OP)")
- ..D COMPILE D:'PSAOUT DONE
- EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q") W:$E(IOST,1,2)="C-" @IOF
- EXIT1 K ^TMP($J,"PSADRG"),%ZIS,DIR,DIRUT,DTOUT
- K PSACHK,PSACNT,PSADRG,PSADT,PSAIEN,PSAINV,PSAISIT,PSAISITN,PSALEN,PSALINK,PSALNK,PSALOC,PSALOCA,PSALOCN,PSAOSIT,PSAOSITN
- K PSAOUT,PSAPG,PSARPDT,PSAS,PSASEL,PSASITES,PSASLN,PSASS,PSATMP,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
- Q
- COMPILE ;Creates ^TMP(Drug Name)= current balance ^ dispense unit ^ total inventory (current balance in 50)
- K ^TMP($J,"PSADRG")
- S PSADRG=0 F S PSADRG=+$O(^PSD(58.8,PSAIEN,1,PSADRG)) Q:'PSADRG D
- .Q:'$D(^PSDRUG(PSADRG,0))
- .I $P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)=0,$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",14)<DT Q ;*53 0 QT & inactive
- .S ^TMP($J,"PSADRG",$P(^PSDRUG(PSADRG,0),"^"))=$P($G(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)_"^"_$P($G(^PSDRUG(PSADRG,660)),"^",8)_"^"_$P($G(^PSDRUG(PSADRG,660.1)),"^")
- PRINT ;Prints body of report
- ;Finds longest length of inventory link(s).
- S (PSALNK,PSALEN)=0 F S PSALNK=+$O(^PSD(58.8,PSAIEN,4,PSALNK)) Q:'PSALNK D
- .S PSALINK(+$P($G(^PSD(58.8,PSAIEN,4,PSALNK,0)),"^"))=""
- .S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
- .S:PSALEN<$L(PSAINV) PSALEN=$L(PSAINV)
- S PSAPG=0,PSADRG="" D HDR
- ;If no data in ^TMP, prints message & exit routine.
- S PSATMP=$O(^TMP($J,"PSADRG","")) I PSATMP="" W !!,"<< NO DRUGS WERE FOUND. >>",! G DONE
- ;If data is found, prints drug name, current balance, & dispense unit
- F S PSADRG=$O(^TMP($J,"PSADRG",PSADRG)) Q:PSADRG="" D I PSAOUT W:$E(IOST,1,2)="C-" @IOF Q
- .D:$Y+4>IOSL HDR Q:PSAOUT
- .W !,PSADRG
- .S PSALEN=$L($P($P(^TMP($J,"PSADRG",PSADRG),"^"),".",2))
- .W ?(44+PSALEN),$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^"),",",PSALEN),(10+PSALEN))
- .W:$P(^TMP($J,"PSADRG",PSADRG),"^",2)'="" ?61,$P(^TMP($J,"PSADRG",PSADRG),"^",2)
- .W ?69,$J($FN($P(^TMP($J,"PSADRG",PSADRG),"^",3),",",0),9)
- Q
- DONE ;Holds screen or ejects paper if sent to printer
- I $E(IOST,1,2)="C-" D
- .S PSAS=22-$Y F PSASS=1:1:PSAS W !
- .S DIR(0)="EA",DIR("A")="End of display! Enter RETURN to continue or '^' to exit:" D ^DIR K DIR S:'Y PSAOUT=1
- W:$E(IOST)'="C" @IOF
- Q
- HDR ;Print header
- S PSAPG=PSAPG+1
- I PSAPG=1,$E(IOST,1,2)="C-" W @IOF
- I PSAPG>1,$E(IOST)'="C" W @IOF
- I $E(IOST,1,2)="C-",PSAPG>1 D Q:PSAOUT
- .S PSAS=22-$Y F PSASS=1:1:PSAS W !
- .S DIR(0)="E" D ^DIR K DIR W:'$G(DIRUT) @IOF S:'Y PSAOUT=1
- W:$E(IOST)'="C" !!,PSARPDT W:$E(IOST,1,2)="C-" !
- W ?21,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$J(PSAPG,2)
- W !?24,"DRUG BALANCES BY LOCATION REPORT"
- W !?((80-$L(PSALOCN))/2),PSALOCN
- S PSALNK=0 F S PSALNK=$O(PSALINK(PSALNK)) Q:'PSALNK D
- .S PSAINV="INVENTORY LINK: "_$S($P($G(^PRCP(445,PSALNK,0)),"^")'="":$P($G(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
- .W !?((80-$L(PSAINV))/2),PSAINV
- W !!?47,"CURRENT",?58,"DISPENSE",?72,"TOTAL"
- W !,"DRUG NAME",?47,"BALANCE",?60,"UNIT",?70,"INVENTORY",!,PSASLN
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSADAI 4512 printed Feb 18, 2025@23:15:30 Page 2
- PSADAI ;BIR/LTL/,JMB/PDW-Drug Balances by Location ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**15,53**; 10/24/97
- +2 ;
- +3 ;Reference to ^PS(59.4 are covered by IA #2505
- +4 ;References to ^PSDRUG( are covered by IA #2095
- +5 ;References to ^PRCP( are covered by IA #214
- +6 ;References to ^PS(59 are covered by IA #212
- +7 ;
- LOC SET (PSACNT,PSAOUT)=0
- DO ^PSAUTL3
- if PSAOUT
- GOTO EXIT1
- +1 SET PSACNT=0
- SET PSACHK=$ORDER(PSALOC(""))
- +2 IF PSACHK=""
- IF 'PSALOC
- WRITE !,"There are no active pharmacy locations."
- GOTO EXIT1
- +3 IF PSACHK'=""
- IF $GET(PSASEL)=""
- IF PSALOC
- WRITE !!,PSALOCN
- +4 ;
- DEVICE WRITE !
- KILL IO("Q")
- SET %ZIS="Q"
- DO ^%ZIS
- IF POP
- SET DTOUT=1
- SET Y=-1
- WRITE !,"No Device was selected or output printed."
- GOTO EXIT1
- +1 IF $DATA(IO("Q"))
- SET ZTRTN="START^PSADAI"
- SET ZTDESC="Drug Accountability - Drug Location Report"
- SET ZTSAVE("PSALOC(")=""
- DO ^%ZTLOAD
- DO HOME^%ZIS
- SET Y=1
- GOTO EXIT1
- START SET PSAOUT=0
- SET PSALOCN=""
- SET $PIECE(PSASLN,"-",80)=""
- +1 SET PSARPDT=$EXTRACT($$HTFM^XLFDT($HOROLOG),1,12)
- SET PSADT=$PIECE(PSARPDT,".")
- +2 SET PSARPDT=$EXTRACT(PSADT,4,5)_"/"_$EXTRACT(PSADT,6,7)_"/"_$EXTRACT(PSADT,2,3)_"@"_$PIECE(PSARPDT,".",2)
- +3 FOR
- SET PSALOCN=$ORDER(PSALOC(PSALOCN))
- if PSALOCN=""
- QUIT
- Begin DoDot:1
- +4 SET PSAIEN=0
- FOR
- SET PSAIEN=+$ORDER(PSALOC(PSALOCN,PSAIEN))
- if 'PSAIEN
- QUIT
- Begin DoDot:2
- +5 SET PSAISIT=+$PIECE(PSALOC(PSALOCN,PSAIEN),"^")
- SET PSAOSIT=+$PIECE(PSALOC(PSALOCN,PSAIEN),"^",2)
- +6 SET PSAISITN=$SELECT($PIECE($GET(^PS(59.4,PSAISIT,0)),"^")'="":$PIECE($GET(^PS(59.4,PSAISIT,0)),"^"),1:"UNKNOWN")
- +7 SET PSAOSITN=$SELECT($PIECE($GET(^PS(59,PSAOSIT,0)),"^")'="":$PIECE($GET(^PS(59,PSAOSIT,0)),"^"),1:"UNKNOWN")
- +8 SET PSASITES=$SELECT(PSAISIT&(PSAOSIT):PSAISITN_" (IP) "_PSAOSITN_" (OP)",PSAISIT:PSAISITN_" (IP)",1:PSAOSITN_" (OP)")
- +9 DO COMPILE
- if 'PSAOUT
- DO DONE
- End DoDot:2
- if PSAOUT
- QUIT
- End DoDot:1
- if PSAOUT
- QUIT
- EXIT DO ^%ZISC
- if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- KILL IO("Q")
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- EXIT1 KILL ^TMP($JOB,"PSADRG"),%ZIS,DIR,DIRUT,DTOUT
- +1 KILL PSACHK,PSACNT,PSADRG,PSADT,PSAIEN,PSAINV,PSAISIT,PSAISITN,PSALEN,PSALINK,PSALNK,PSALOC,PSALOCA,PSALOCN,PSAOSIT,PSAOSITN
- +2 KILL PSAOUT,PSAPG,PSARPDT,PSAS,PSASEL,PSASITES,PSASLN,PSASS,PSATMP,X,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
- +3 QUIT
- COMPILE ;Creates ^TMP(Drug Name)= current balance ^ dispense unit ^ total inventory (current balance in 50)
- +1 KILL ^TMP($JOB,"PSADRG")
- +2 SET PSADRG=0
- FOR
- SET PSADRG=+$ORDER(^PSD(58.8,PSAIEN,1,PSADRG))
- if 'PSADRG
- QUIT
- Begin DoDot:1
- +3 if '$DATA(^PSDRUG(PSADRG,0))
- QUIT
- +4 ;*53 0 QT & inactive
- IF $PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)=0
- IF $PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",14)<DT
- QUIT
- +5 SET ^TMP($JOB,"PSADRG",$PIECE(^PSDRUG(PSADRG,0),"^"))=$PIECE($GET(^PSD(58.8,PSAIEN,1,PSADRG,0)),"^",4)_"^"_$PIECE($GET(^PSDRUG(PSADRG,660)),"^",8)_"^"_$PIECE($GET(^PSDRUG(PSADRG,660.1)),"^")
- End DoDot:1
- PRINT ;Prints body of report
- +1 ;Finds longest length of inventory link(s).
- +2 SET (PSALNK,PSALEN)=0
- FOR
- SET PSALNK=+$ORDER(^PSD(58.8,PSAIEN,4,PSALNK))
- if 'PSALNK
- QUIT
- Begin DoDot:1
- +3 SET PSALINK(+$PIECE($GET(^PSD(58.8,PSAIEN,4,PSALNK,0)),"^"))=""
- +4 SET PSAINV="INVENTORY LINK: "_$SELECT($PIECE($GET(^PRCP(445,PSALNK,0)),"^")'="":$PIECE($GET(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
- +5 if PSALEN<$LENGTH(PSAINV)
- SET PSALEN=$LENGTH(PSAINV)
- End DoDot:1
- +6 SET PSAPG=0
- SET PSADRG=""
- DO HDR
- +7 ;If no data in ^TMP, prints message & exit routine.
- +8 SET PSATMP=$ORDER(^TMP($JOB,"PSADRG",""))
- IF PSATMP=""
- WRITE !!,"<< NO DRUGS WERE FOUND. >>",!
- GOTO DONE
- +9 ;If data is found, prints drug name, current balance, & dispense unit
- +10 FOR
- SET PSADRG=$ORDER(^TMP($JOB,"PSADRG",PSADRG))
- if PSADRG=""
- QUIT
- Begin DoDot:1
- +11 if $Y+4>IOSL
- DO HDR
- if PSAOUT
- QUIT
- +12 WRITE !,PSADRG
- +13 SET PSALEN=$LENGTH($PIECE($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^"),".",2))
- +14 WRITE ?(44+PSALEN),$JUSTIFY($FNUMBER($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^"),",",PSALEN),(10+PSALEN))
- +15 if $PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",2)'=""
- WRITE ?61,$PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",2)
- +16 WRITE ?69,$JUSTIFY($FNUMBER($PIECE(^TMP($JOB,"PSADRG",PSADRG),"^",3),",",0),9)
- End DoDot:1
- IF PSAOUT
- if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- QUIT
- +17 QUIT
- DONE ;Holds screen or ejects paper if sent to printer
- +1 IF $EXTRACT(IOST,1,2)="C-"
- Begin DoDot:1
- +2 SET PSAS=22-$Y
- FOR PSASS=1:1:PSAS
- WRITE !
- +3 SET DIR(0)="EA"
- SET DIR("A")="End of display! Enter RETURN to continue or '^' to exit:"
- DO ^DIR
- KILL DIR
- if 'Y
- SET PSAOUT=1
- End DoDot:1
- +4 if $EXTRACT(IOST)'="C"
- WRITE @IOF
- +5 QUIT
- HDR ;Print header
- +1 SET PSAPG=PSAPG+1
- +2 IF PSAPG=1
- IF $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- +3 IF PSAPG>1
- IF $EXTRACT(IOST)'="C"
- WRITE @IOF
- +4 IF $EXTRACT(IOST,1,2)="C-"
- IF PSAPG>1
- Begin DoDot:1
- +5 SET PSAS=22-$Y
- FOR PSASS=1:1:PSAS
- WRITE !
- +6 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- if '$GET(DIRUT)
- WRITE @IOF
- if 'Y
- SET PSAOUT=1
- End DoDot:1
- if PSAOUT
- QUIT
- +7 if $EXTRACT(IOST)'="C"
- WRITE !!,PSARPDT
- if $EXTRACT(IOST,1,2)="C-"
- WRITE !
- +8 WRITE ?21,"D R U G A C C O U N T A B I L I T Y",?71,"Page ",$JUSTIFY(PSAPG,2)
- +9 WRITE !?24,"DRUG BALANCES BY LOCATION REPORT"
- +10 WRITE !?((80-$LENGTH(PSALOCN))/2),PSALOCN
- +11 SET PSALNK=0
- FOR
- SET PSALNK=$ORDER(PSALINK(PSALNK))
- if 'PSALNK
- QUIT
- Begin DoDot:1
- +12 SET PSAINV="INVENTORY LINK: "_$SELECT($PIECE($GET(^PRCP(445,PSALNK,0)),"^")'="":$PIECE($GET(^PRCP(445,PSALNK,0)),"^"),1:"NONE")
- +13 WRITE !?((80-$LENGTH(PSAINV))/2),PSAINV
- End DoDot:1
- +14 WRITE !!?47,"CURRENT",?58,"DISPENSE",?72,"TOTAL"
- +15 WRITE !,"DRUG NAME",?47,"BALANCE",?60,"UNIT",?70,"INVENTORY",!,PSASLN
- +16 QUIT