- 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 Jan 18, 2025@03:34:02 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