PSSOICT ;BIR/RTR-Orderable Item status ; 09/02/97 8:41
;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
N PSSITE,QFLAG,AA,FF,FFFF,MMM,PSDATE,A,AA,APP,B,SS,ZZ,ZZZ
S PSSITE=+$O(^PS(59.7,0)) I $P($G(^PS(59.7,PSSITE,80)),"^",2)'=2 W !!?3,$S($P($G(^(80)),"^",2)<2:"Orderable Item Auto-Create has not been completed!",1:"Manual Matching process complete!"),!! K PSSITE G EXIT
W !,"This option looks at the 3 files that must be matched to the Orderable Item",!,"File, and tells you how many more need to be matched. The 3 files are:"
W !!?5,"IV ADDITIVES File",!?5,"IV SOLUTIONS File",!?5,"DRUG File"
W !!,"(Lists will not include drugs that do not require matching.)"
W ! S %ZIS="QM" D ^%ZIS I POP G EXIT
I $D(IO("Q")) D Q
.S ZTRTN="BEG^PSSOICT",ZTDESC="Pharmacy Orderable Item Status Report" D ^%ZTLOAD K IO("Q") W !,"Report queued to print!",!
BEG U IO
S QFLAG=0
;I $E(IOST)="C" D DIRX I $G(Y)'=1 G EXIT
S X1=DT,X2=-365 D C^%DTC S PDATE=X
I $E(IOST)="C" W !!,"Finding IV ADDITIVES that aren't matched, hold on:" F II=1:1:3 W "." H 1
I $E(IOST)'="C" D ADDHEAD
S MM=0
I $E(IOST)="C" W !
F AA=0:0 S AA=$O(^PS(52.6,AA)) Q:'AA!($G(QFLAG)) I '$P($G(^PS(52.6,AA,0)),"^",11) D
.S DD=$P($G(^PS(52.6,AA,0)),"^",2)
.I 'DD Q
.S FFFF=$P($G(^PS(52.6,AA,"I")),"^") I FFFF,FFFF<PDATE Q
.D:MM=0 W !,$P($G(^PS(52.6,AA,0)),"^"),?41,"Still needs to be matched." S MM=MM+1 I ($Y+4)>IOSL D:$E(IOST)="C" DIRX D:$E(IOST)'="C" ADDHEAD S:$G(Y)'=1&($E(IOST)="C") QFLAG=1 I '$G(QFLAG)&($E(IOST)="C") W @IOF
..I $E(IOST)="C" W @IOF W !?5,"IV ADDITIVES that need matched:",!
I $G(QFLAG) G EXIT
I 'MM W !,"All IV ADDITIVES are matched that should be matched!",!
I MM W $C(7),!!?3,MM," IV ADDITIVE(S) still need to be matched!",! H 1
I $E(IOST)="C" D DIRX I $G(Y)'=1 G EXIT
G ^PSSOICT1
;
EXIT D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K ^TMP($J,"PSSLIST") Q
DIRX ;
W ! K DIR S DIR(0)="E",DIR("A")="Press Return to Continue, '^' to Exit" D ^DIR K DIR Q
ADDHEAD W @IOF W !,"IV ADDITIVE(S) THAT AREN'T MATCHED",!,"________________________________",! Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSOICT 2062 printed Apr 09, 2024@21:32:57 Page 2
PSSOICT ;BIR/RTR-Orderable Item status ; 09/02/97 8:41
+1 ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
+2 NEW PSSITE,QFLAG,AA,FF,FFFF,MMM,PSDATE,A,AA,APP,B,SS,ZZ,ZZZ
+3 SET PSSITE=+$ORDER(^PS(59.7,0))
IF $PIECE($GET(^PS(59.7,PSSITE,80)),"^",2)'=2
WRITE !!?3,$SELECT($PIECE($GET(^(80)),"^",2)<2:"Orderable Item Auto-Create has not been completed!",1:"Manual Matching process complete!"),!!
KILL PSSITE
GOTO EXIT
+4 WRITE !,"This option looks at the 3 files that must be matched to the Orderable Item",!,"File, and tells you how many more need to be matched. The 3 files are:"
+5 WRITE !!?5,"IV ADDITIVES File",!?5,"IV SOLUTIONS File",!?5,"DRUG File"
+6 WRITE !!,"(Lists will not include drugs that do not require matching.)"
+7 WRITE !
SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO EXIT
+8 IF $DATA(IO("Q"))
Begin DoDot:1
+9 SET ZTRTN="BEG^PSSOICT"
SET ZTDESC="Pharmacy Orderable Item Status Report"
DO ^%ZTLOAD
KILL IO("Q")
WRITE !,"Report queued to print!",!
End DoDot:1
QUIT
BEG USE IO
+1 SET QFLAG=0
+2 ;I $E(IOST)="C" D DIRX I $G(Y)'=1 G EXIT
+3 SET X1=DT
SET X2=-365
DO C^%DTC
SET PDATE=X
+4 IF $EXTRACT(IOST)="C"
WRITE !!,"Finding IV ADDITIVES that aren't matched, hold on:"
FOR II=1:1:3
WRITE "."
HANG 1
+5 IF $EXTRACT(IOST)'="C"
DO ADDHEAD
+6 SET MM=0
+7 IF $EXTRACT(IOST)="C"
WRITE !
+8 FOR AA=0:0
SET AA=$ORDER(^PS(52.6,AA))
if 'AA!($GET(QFLAG))
QUIT
IF '$PIECE($GET(^PS(52.6,AA,0)),"^",11)
Begin DoDot:1
+9 SET DD=$PIECE($GET(^PS(52.6,AA,0)),"^",2)
+10 IF 'DD
QUIT
+11 SET FFFF=$PIECE($GET(^PS(52.6,AA,"I")),"^")
IF FFFF
IF FFFF<PDATE
QUIT
+12 if MM=0
Begin DoDot:2
+13 IF $EXTRACT(IOST)="C"
WRITE @IOF
WRITE !?5,"IV ADDITIVES that need matched:",!
End DoDot:2
WRITE !,$PIECE($GET(^PS(52.6,AA,0)),"^"),?41,"Still needs to be matched."
SET MM=MM+1
IF ($Y+4)>IOSL
if $EXTRACT(IOST)="C"
DO DIRX
if $EXTRACT(IOST)'="C"
DO ADDHEAD
if $GET(Y)'=1&($EXTRACT(IOST)="C")
SET QFLAG=1
IF '$GET(QFLAG)&($EXTRACT(IOST)="C")
WRITE @IOF
End DoDot:1
+14 IF $GET(QFLAG)
GOTO EXIT
+15 IF 'MM
WRITE !,"All IV ADDITIVES are matched that should be matched!",!
+16 IF MM
WRITE $CHAR(7),!!?3,MM," IV ADDITIVE(S) still need to be matched!",!
HANG 1
+17 IF $EXTRACT(IOST)="C"
DO DIRX
IF $GET(Y)'=1
GOTO EXIT
+18 GOTO ^PSSOICT1
+19 ;
EXIT DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL ^TMP($JOB,"PSSLIST")
QUIT
DIRX ;
+1 WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to Continue, '^' to Exit"
DO ^DIR
KILL DIR
QUIT
ADDHEAD WRITE @IOF
WRITE !,"IV ADDITIVE(S) THAT AREN'T MATCHED",!,"________________________________",!
QUIT
