- PSSOICT1 ;BIR/RTR-ORDERABLE ITEM STATUS continued ; 09/02/97 8:41
- ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
- S X1=DT,X2=-365 D C^%DTC S PDATE=X
- S QFLAG=0
- I $E(IOST)="C" W !!,"Finding IV SOLUTIONS that aren't matched, hold on:" F II=1:1:3 W "." H 1
- I $E(IOST)'="C" D SOLHEAD
- S MM=0
- I $E(IOST)="C" W !
- F AA=0:0 S AA=$O(^PS(52.7,AA)) Q:'AA!($G(QFLAG)) I '$P($G(^PS(52.7,AA,0)),"^",11) D
- .S DD=$P(^PS(52.7,AA,0),"^",2)
- .I 'DD Q
- .S FFFF=$P($G(^PS(52.7,AA,"I")),"^") I FFFF,FFFF<PDATE Q
- .D:MM=0 W !,$P($G(^PS(52.7,AA,0)),"^"),?35,$P($G(^(0)),"^",3),?55,"Still needs matched." S MM=MM+1 I ($Y+4)>IOSL D:$E(IOST)="C" DIRX^PSSOICT D:$E(IOST)'="C" SOLHEAD 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 SOLUTION(S) that need matched:",!
- I $G(QFLAG) G EXIT^PSSOICT
- I 'MM W !,"All IV SOLUTIONS are matched that should be matched!",!
- I MM W $C(7),!!?3,MM," IV SOLUTION(S) still need to be matched!",! H 1
- I $E(IOST)="C" D DIRX^PSSOICT I $G(Y)'=1 G EXIT^PSSOICT
- I $E(IOST)="C" W !!,"Finding DISPENSE Drug(s) that aren't matched, hold on:" W ! H 1 F II=1:1:4 W "."
- S A=1,B=0
- K ^TMP($J,"PSSLIST")
- S ZZZ="" F S ZZZ=$O(^PSDRUG("B",ZZZ)) Q:ZZZ=""!($G(QFLAG)) S ZZ=$O(^PSDRUG("B",ZZZ,0)) I ZZ,$D(^PSDRUG(ZZ,0)),'$P($G(^PSDRUG(ZZ,2)),"^") D
- .S APP=$P($G(^PSDRUG(ZZ,2)),"^",3) I APP'["O",APP'["I",APP'["U" Q
- .S SS=$P($G(^PSDRUG(ZZ,"I")),"^") I SS,SS<PDATE Q
- .I $E(IOST)="C" I ZZ>99,$E(ZZ,($L(ZZ)-1),($L(ZZ)))="00" W "."
- .I '$P($G(^PSDRUG(ZZ,"ND")),"^") S B=B+1
- .S ^TMP($J,"PSSLIST",A)=$P($G(^PSDRUG(ZZ,0)),"^") S A=A+1 I $E(IOST)="C" W "."
- I $E(IOST)'="C" D DH
- I A=1 W !!,"All DISPENSE Drugs are matched that should be matched!" H 2 W ! G EXIT^PSSOICT
- W !!,(A-1)," DISPENSE drugs still need to be matched!" H 1
- I B W !!,B," because Drug is not matched to National Drug File",! H 1
- I $E(IOST)="C" K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Do you want to see these Drugs" D ^DIR K DIR I $G(Y)'=1 G EXIT^PSSOICT
- I $E(IOST)="C" W @IOF
- I $E(IOST)'="C" D DH
- F XXX=0:0 S XXX=$O(^TMP($J,"PSSLIST",XXX)) Q:'XXX!($G(QFLAG)) W !,$G(^(XXX)),?43,"Still needs to be matched." I ($Y+4)>IOSL D:$E(IOST)="C" DIRX^PSSOICT D:$E(IOST)'="C" DH S:$G(Y)'=1&($E(IOST)="C") QFLAG=1 I '$G(QFLAG)&($E(IOST)="C") W @IOF
- I '$G(QFLAG) W !!,"END OF LIST",!
- END ;
- G EXIT^PSSOICT
- SOLHEAD W @IOF W !,"IV SOLUTION(S) THAT AREN'T MATCHED",!,"________________________________",! Q
- DH W @IOF W !,"DISPENSE DRUG(S) THAT AREN'T MATCHED",!,"__________________________________",! Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSOICT1 2552 printed Jan 18, 2025@03:34:03 Page 2
- PSSOICT1 ;BIR/RTR-ORDERABLE ITEM STATUS continued ; 09/02/97 8:41
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;;9/30/97
- +2 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET PDATE=X
- +3 SET QFLAG=0
- +4 IF $EXTRACT(IOST)="C"
- WRITE !!,"Finding IV SOLUTIONS that aren't matched, hold on:"
- FOR II=1:1:3
- WRITE "."
- HANG 1
- +5 IF $EXTRACT(IOST)'="C"
- DO SOLHEAD
- +6 SET MM=0
- +7 IF $EXTRACT(IOST)="C"
- WRITE !
- +8 FOR AA=0:0
- SET AA=$ORDER(^PS(52.7,AA))
- if 'AA!($GET(QFLAG))
- QUIT
- IF '$PIECE($GET(^PS(52.7,AA,0)),"^",11)
- Begin DoDot:1
- +9 SET DD=$PIECE(^PS(52.7,AA,0),"^",2)
- +10 IF 'DD
- QUIT
- +11 SET FFFF=$PIECE($GET(^PS(52.7,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 SOLUTION(S) that need matched:",!
- End DoDot:2
- WRITE !,$PIECE($GET(^PS(52.7,AA,0)),"^"),?35,$PIECE($GET(^(0)),"^",3),?55,"Still needs matched."
- SET MM=MM+1
- IF ($Y+4)>IOSL
- if $EXTRACT(IOST)="C"
- DO DIRX^PSSOICT
- if $EXTRACT(IOST)'="C"
- DO SOLHEAD
- 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^PSSOICT
- +15 IF 'MM
- WRITE !,"All IV SOLUTIONS are matched that should be matched!",!
- +16 IF MM
- WRITE $CHAR(7),!!?3,MM," IV SOLUTION(S) still need to be matched!",!
- HANG 1
- +17 IF $EXTRACT(IOST)="C"
- DO DIRX^PSSOICT
- IF $GET(Y)'=1
- GOTO EXIT^PSSOICT
- +18 IF $EXTRACT(IOST)="C"
- WRITE !!,"Finding DISPENSE Drug(s) that aren't matched, hold on:"
- WRITE !
- HANG 1
- FOR II=1:1:4
- WRITE "."
- +19 SET A=1
- SET B=0
- +20 KILL ^TMP($JOB,"PSSLIST")
- +21 SET ZZZ=""
- FOR
- SET ZZZ=$ORDER(^PSDRUG("B",ZZZ))
- if ZZZ=""!($GET(QFLAG))
- QUIT
- SET ZZ=$ORDER(^PSDRUG("B",ZZZ,0))
- IF ZZ
- IF $DATA(^PSDRUG(ZZ,0))
- IF '$PIECE($GET(^PSDRUG(ZZ,2)),"^")
- Begin DoDot:1
- +22 SET APP=$PIECE($GET(^PSDRUG(ZZ,2)),"^",3)
- IF APP'["O"
- IF APP'["I"
- IF APP'["U"
- QUIT
- +23 SET SS=$PIECE($GET(^PSDRUG(ZZ,"I")),"^")
- IF SS
- IF SS<PDATE
- QUIT
- +24 IF $EXTRACT(IOST)="C"
- IF ZZ>99
- IF $EXTRACT(ZZ,($LENGTH(ZZ)-1),($LENGTH(ZZ)))="00"
- WRITE "."
- +25 IF '$PIECE($GET(^PSDRUG(ZZ,"ND")),"^")
- SET B=B+1
- +26 SET ^TMP($JOB,"PSSLIST",A)=$PIECE($GET(^PSDRUG(ZZ,0)),"^")
- SET A=A+1
- IF $EXTRACT(IOST)="C"
- WRITE "."
- End DoDot:1
- +27 IF $EXTRACT(IOST)'="C"
- DO DH
- +28 IF A=1
- WRITE !!,"All DISPENSE Drugs are matched that should be matched!"
- HANG 2
- WRITE !
- GOTO EXIT^PSSOICT
- +29 WRITE !!,(A-1)," DISPENSE drugs still need to be matched!"
- HANG 1
- +30 IF B
- WRITE !!,B," because Drug is not matched to National Drug File",!
- HANG 1
- +31 IF $EXTRACT(IOST)="C"
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="Y"
- SET DIR("A")="Do you want to see these Drugs"
- DO ^DIR
- KILL DIR
- IF $GET(Y)'=1
- GOTO EXIT^PSSOICT
- +32 IF $EXTRACT(IOST)="C"
- WRITE @IOF
- +33 IF $EXTRACT(IOST)'="C"
- DO DH
- +34 FOR XXX=0:0
- SET XXX=$ORDER(^TMP($JOB,"PSSLIST",XXX))
- if 'XXX!($GET(QFLAG))
- QUIT
- WRITE !,$GET(^(XXX)),?43,"Still needs to be matched."
- IF ($Y+4)>IOSL
- if $EXTRACT(IOST)="C"
- DO DIRX^PSSOICT
- if $EXTRACT(IOST)'="C"
- DO DH
- if $GET(Y)'=1&($EXTRACT(IOST)="C")
- SET QFLAG=1
- IF '$GET(QFLAG)&($EXTRACT(IOST)="C")
- WRITE @IOF
- +35 IF '$GET(QFLAG)
- WRITE !!,"END OF LIST",!
- END ;
- +1 GOTO EXIT^PSSOICT
- SOLHEAD WRITE @IOF
- WRITE !,"IV SOLUTION(S) THAT AREN'T MATCHED",!,"________________________________",!
- QUIT
- DH WRITE @IOF
- WRITE !,"DISPENSE DRUG(S) THAT AREN'T MATCHED",!,"__________________________________",!
- QUIT