- PSSPOIM3 ;BIR/RTR/WRT-Initial Solution and Additive matching ; 10/09/97 13:08
- ;;1.0;PHARMACY DATA MANAGEMENT;**2**;9/30/97
- ;
- S (PSSSSS1,PSOOOUT)=0,PSSSSS=1
- S X1=DT,X2=-365 D C^%DTC S PSXDATE=X
- W !!?5,"MATCHING IV ADDITIVES!",! S BBBBB="" F S BBBBB=$O(^PS(52.6,"B",BBBBB)) Q:BBBBB=""!($G(PSOOOUT)) F AAAA=0:0 S AAAA=$O(^PS(52.6,"B",BBBBB,AAAA)) Q:'AAAA!($G(PSOOOUT)) I AAAA,$D(^PS(52.6,AAAA,0)),'$P(^(0),"^",11),$P(^(0),"^",2) D
- .S BBBB=+$P(^PS(52.6,AAAA,0),"^",2) Q:'$D(^PSDRUG(BBBB,0))
- .S PSXADATE=+$P($G(^PS(52.6,AAAA,"I")),"^") I PSXADATE,PSXADATE<PSXDATE Q
- .S PSSSSS1=1
- .S PSAIEN=AAAA,PSANAME=$P(^PS(52.6,PSAIEN,0),"^"),PSDISP=$P(^(0),"^",2),PSPOI=$P(^(0),"^",11) W !,"IV Additive -> ",PSANAME,! S PSSSSS=1 D ENTER^PSSADDIT
- .W ! K DIR S DIR(0)="Y",DIR("A")="Continue matching IV Additives",DIR("B")="YES" D ^DIR W !! K DIR I Y'=1 S PSOOOUT=1
- I 'PSSSSS1 W !?3,"IV Additives are all matched!",!
- I $G(PSOOOUT) G END
- SOL K PSPOI S PSSSSS1=0,PSSSSS=1
- W !!?5,"MATCHING IV SOLUTIONS!",! S AAAAA="" F S AAAAA=$O(^PS(52.7,"B",AAAAA)) Q:AAAAA=""!($G(PSOOOUT)) F AAAA=0:0 S AAAA=$O(^PS(52.7,"B",AAAAA,AAAA)) Q:'AAAA!($G(PSOOOUT)) I AAAA,$D(^PS(52.7,AAAA,0)),'$P(^(0),"^",11),$P(^(0),"^",2) D
- .S BBBB=+$P(^PS(52.7,AAAA,0),"^",2) Q:'$D(^PSDRUG(BBBB,0))
- .S PSXSDATE=+$P($G(^PS(52.7,AAAA,"I")),"^") I PSXSDATE,PSXSDATE<PSXDATE Q
- .S PSSSSS1=1
- .S PSSIEN=AAAA,PSSNAME=$P(^PS(52.7,AAAA,0),"^"),PSDISP=$P(^(0),"^",2),PSSOI=$P(^(0),"^",11),PSSVOL=$P(^(0),"^",3) W !!,"IV Solution -> ",PSSNAME," ",PSSVOL S PSSSSS=1 D ENTER^PSSSOLIT
- .W ! K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Continue matching IV Solutions" D ^DIR W !! K DIR I Y'=1 S PSOOOUT=1
- I 'PSSSSS1 W !?3,"IV Solutions are all matched!",!
- END K PSSSSS1,AAAA,BBBB,CCCC Q
- ;
- DIR I $G(PSOIEN),$D(^PS(50.7,PSOIEN)),$P(^PS(50.7,PSOIEN,0),"^",4)]"" W !!,"This Orderable Item is Inactive. ***" S Y=$P(^PS(50.7,PSOIEN,0),"^",4) X ^DD("DD") W ?43,Y,!
- I $G(PSSOI),$D(^PS(50.7,PSSOI)),$P(^PS(50.7,PSSOI,0),"^",4)]"" W !!,"This Orderable Item is Inactive. ***" S Y=$P(^PS(50.7,PSSOI,0),"^",4) X ^DD("DD") W ?43,Y,!
- I $G(PSPOI),$D(^PS(50.7,PSPOI)),$P(^PS(50.7,PSPOI,0),"^",4)]"" W !!,"This Orderable Item is Inactive. ***" S Y=$P(^PS(50.7,PSPOI,0),"^",4) X ^DD("DD") W ?43,Y,!
- K DIR,PSSDIR S DIR(0)="Y",DIR("B")="NO",DIR("A")="Edit Orderable Item" D ^DIR K DIR I Y=1 S PSSDIR=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSPOIM3 2378 printed Jan 18, 2025@03:34:44 Page 2
- PSSPOIM3 ;BIR/RTR/WRT-Initial Solution and Additive matching ; 10/09/97 13:08
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**2**;9/30/97
- +2 ;
- +3 SET (PSSSSS1,PSOOOUT)=0
- SET PSSSSS=1
- +4 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET PSXDATE=X
- +5 WRITE !!?5,"MATCHING IV ADDITIVES!",!
- SET BBBBB=""
- FOR
- SET BBBBB=$ORDER(^PS(52.6,"B",BBBBB))
- if BBBBB=""!($GET(PSOOOUT))
- QUIT
- FOR AAAA=0:0
- SET AAAA=$ORDER(^PS(52.6,"B",BBBBB,AAAA))
- if 'AAAA!($GET(PSOOOUT))
- QUIT
- IF AAAA
- IF $DATA(^PS(52.6,AAAA,0))
- IF '$PIECE(^(0),"^",11)
- IF $PIECE(^(0),"^",2)
- Begin DoDot:1
- +6 SET BBBB=+$PIECE(^PS(52.6,AAAA,0),"^",2)
- if '$DATA(^PSDRUG(BBBB,0))
- QUIT
- +7 SET PSXADATE=+$PIECE($GET(^PS(52.6,AAAA,"I")),"^")
- IF PSXADATE
- IF PSXADATE<PSXDATE
- QUIT
- +8 SET PSSSSS1=1
- +9 SET PSAIEN=AAAA
- SET PSANAME=$PIECE(^PS(52.6,PSAIEN,0),"^")
- SET PSDISP=$PIECE(^(0),"^",2)
- SET PSPOI=$PIECE(^(0),"^",11)
- WRITE !,"IV Additive -> ",PSANAME,!
- SET PSSSSS=1
- DO ENTER^PSSADDIT
- +10 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Continue matching IV Additives"
- SET DIR("B")="YES"
- DO ^DIR
- WRITE !!
- KILL DIR
- IF Y'=1
- SET PSOOOUT=1
- End DoDot:1
- +11 IF 'PSSSSS1
- WRITE !?3,"IV Additives are all matched!",!
- +12 IF $GET(PSOOOUT)
- GOTO END
- SOL KILL PSPOI
- SET PSSSSS1=0
- SET PSSSSS=1
- +1 WRITE !!?5,"MATCHING IV SOLUTIONS!",!
- SET AAAAA=""
- FOR
- SET AAAAA=$ORDER(^PS(52.7,"B",AAAAA))
- if AAAAA=""!($GET(PSOOOUT))
- QUIT
- FOR AAAA=0:0
- SET AAAA=$ORDER(^PS(52.7,"B",AAAAA,AAAA))
- if 'AAAA!($GET(PSOOOUT))
- QUIT
- IF AAAA
- IF $DATA(^PS(52.7,AAAA,0))
- IF '$PIECE(^(0),"^",11)
- IF $PIECE(^(0),"^",2)
- Begin DoDot:1
- +2 SET BBBB=+$PIECE(^PS(52.7,AAAA,0),"^",2)
- if '$DATA(^PSDRUG(BBBB,0))
- QUIT
- +3 SET PSXSDATE=+$PIECE($GET(^PS(52.7,AAAA,"I")),"^")
- IF PSXSDATE
- IF PSXSDATE<PSXDATE
- QUIT
- +4 SET PSSSSS1=1
- +5 SET PSSIEN=AAAA
- SET PSSNAME=$PIECE(^PS(52.7,AAAA,0),"^")
- SET PSDISP=$PIECE(^(0),"^",2)
- SET PSSOI=$PIECE(^(0),"^",11)
- SET PSSVOL=$PIECE(^(0),"^",3)
- WRITE !!,"IV Solution -> ",PSSNAME," ",PSSVOL
- SET PSSSSS=1
- DO ENTER^PSSSOLIT
- +6 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("B")="YES"
- SET DIR("A")="Continue matching IV Solutions"
- DO ^DIR
- WRITE !!
- KILL DIR
- IF Y'=1
- SET PSOOOUT=1
- End DoDot:1
- +7 IF 'PSSSSS1
- WRITE !?3,"IV Solutions are all matched!",!
- END KILL PSSSSS1,AAAA,BBBB,CCCC
- QUIT
- +1 ;
- DIR IF $GET(PSOIEN)
- IF $DATA(^PS(50.7,PSOIEN))
- IF $PIECE(^PS(50.7,PSOIEN,0),"^",4)]""
- WRITE !!,"This Orderable Item is Inactive. ***"
- SET Y=$PIECE(^PS(50.7,PSOIEN,0),"^",4)
- XECUTE ^DD("DD")
- WRITE ?43,Y,!
- +1 IF $GET(PSSOI)
- IF $DATA(^PS(50.7,PSSOI))
- IF $PIECE(^PS(50.7,PSSOI,0),"^",4)]""
- WRITE !!,"This Orderable Item is Inactive. ***"
- SET Y=$PIECE(^PS(50.7,PSSOI,0),"^",4)
- XECUTE ^DD("DD")
- WRITE ?43,Y,!
- +2 IF $GET(PSPOI)
- IF $DATA(^PS(50.7,PSPOI))
- IF $PIECE(^PS(50.7,PSPOI,0),"^",4)]""
- WRITE !!,"This Orderable Item is Inactive. ***"
- SET Y=$PIECE(^PS(50.7,PSPOI,0),"^",4)
- XECUTE ^DD("DD")
- WRITE ?43,Y,!
- +3 KILL DIR,PSSDIR
- SET DIR(0)="Y"
- SET DIR("B")="NO"
- SET DIR("A")="Edit Orderable Item"
- DO ^DIR
- KILL DIR
- IF Y=1
- SET PSSDIR=1
- +4 QUIT