- PSSSOLIT ;BIR/RTR/WRT-Manual match Solutions to Orderable Items; 09/02/97 8:54
- ;;1.0;PHARMACY DATA MANAGEMENT;**32,41,125**;9/30/97;Build 2
- ;
- EN I $D(PSSIEN) L -^PS(52.7,PSSIEN)
- D:$G(PSDELSLG) REMSS D:$G(PSMASTER) END Q:$G(PSSSSS)!($G(PSMASTER)) D END W ! S (PSSOUT,CHANGE,CHKFLAG)=0 K DIC S DIC="^PS(52.7,",DIC(0)="QEAMZ",DIC("A")="Select IV SOLUTION: " D ^DIC K DIC G:Y<0!($D(DTOUT))!($D(DUOUT)) END
- MAS ;Entry point for Master Drug Enter/Edit
- S PSSIEN=+Y,PSSNAME=$P(Y,"^",2),PSDISP=+$P($G(^PS(52.7,+Y,0)),"^",2),(PSSOI,PSOLDOI)=+$P($G(^(0)),"^",11),PSSVOL=$P($G(^(0)),"^",3) L +^PS(52.7,PSSIEN):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I '$T W !,$C(7),"Another person is editing this one." Q
- I 'PSDISP W $C(7),!!?5,"This IV Solution does not point to the Dispense Drug File (#50)",!?5,"it cannot be matched to an Orderable Item!",! G EN
- ENTER I 'PSSOI G ^PSSSOLI1
- S PSOINAME=$P($G(^PS(50.7,PSSOI,0)),"^"),PSOIDOSE=+$P($G(^(0)),"^",2) W !!,"IV Solution -> ",PSSNAME," ",PSSVOL,!," is already matched to:",!,PSOINAME," ",$P($G(^PS(50.606,PSOIDOSE,0)),"^")
- W ! K DIR S DIR(0)="Y",DIR("A")="Do you want to re-match this IV Solution",DIR("B")="NO" D ^DIR K DIR I Y'=1 D SELIV G @$S($G(PSSJI)&('$G(PSSIVOUT)):"ENS^PSSVIDRG",1:"EN")
- S PSDELSLG=1,PSDELSOL=PSSIEN,PSDELOIS=PSSOI
- K DIE S DA=PSSIEN,DIE="^PS(52.7,",DR="9////"_"@" D ^DIE K DIE D EN^PSSPOIDT(PSSOI),EN2^PSSHL1(PSSOI,"MUP") K PSOINAME,PSOIDOSE,PSSOI G ^PSSSOLI1
- INACT W ! K DIE S PSBEFORE=$P(^PS(50.7,PSSOI,0),"^",4),PSAFTER=0,PSINORDE="" S DIE="^PS(50.7,",DR=".04;.05;.06;.07;.08",DA=PSSOI D ^DIE S PSAFTER=$P(^PS(50.7,PSSOI,0),"^",4) K DIE
- S:PSBEFORE&('PSAFTER) PSINORDE="D" S:PSAFTER PSINORDE="I"
- I PSINORDE'="" D REST^PSSPOIDT(PSSOI)
- K PSBEFORE,PSAFTER,PSINORDE
- SYN W ! K DIC S:'$D(^PS(50.7,PSSOI,2,0)) ^PS(50.7,PSSOI,2,0)="^50.72^0^0" S DIC="^PS(50.7,"_PSSOI_",2,",DA(1)=PSSOI,DIC(0)="QEAMLZ",DIC("A")="Select SYNONYM: ",DLAYGO=50.7 D ^DIC K DIC
- I Y<0!($D(DTOUT))!($D(DUOUT)) K:'$O(^PS(50.7,PSSOI,2,0)) ^PS(50.7,PSSOI,2,0) Q:$G(NEWFLAG) D EN^PSSPOIDT(PSSOI) D:'$G(PSSSSS) EN2^PSSHL1(PSSOI,"MUP") G EN
- W ! S DA=+Y,DIE="^PS(50.7,"_PSSOI_",2,",DA(1)=PSSOI,DR=.01 D ^DIE K DIE G SYN
- Q:$G(NEWFLAG) D EN^PSSPOIDT(PSSOI) D:'$G(PSSSSS) EN2^PSSHL1(PSSOI,"MUP")
- G EN
- END I $D(PSSIEN) L -^PS(52.7,PSSIEN)
- K DA,DIC,DIR,PSSIEN,PSSNAME,PSDISP,PSSOI,PSDOSNM,CHANGE,CHKFLAG,DA,DR,DIR,DIE,INFLAG,HOLDOI,INPUT,J,JJ,HOLDNAME,NEWFLAG,PSDOSPTR,PSND,PSND1,PSND3,PSNDOSE,PSOIDOSE,PSOINAME,PSOLDOI,PSONEW,PSOTHER,PSSOUT,PSSVOL,ZZ,ZZZZFLAG,ZZPOI,ZZFLAG
- K SS,QQ,WW,PSNEWOI,PPFLAG,VV,VVV,TT,SCLAST,SYN,SYN1,SCOUNT,PSANS,ZZFLAG,ZZXFLAG,PSPOI,SYNNAM,PSDELSOL,PSDELSLG,PSDELOIS,PSSSSS Q
- Q
- REMAT ;Rematch Additive to Orderable Item
- I '$G(PSDELADD)!('$G(PSDELOIT)) G QREMAT
- I $P($G(^PS(52.6,PSDELADD,0)),"^",11) G QREMAT
- I $P($G(^PS(50.7,+PSDELOIT,0)),"^",3),'$O(^PS(52.6,"AOI",+PSDELOIT,0)) D
- .K DIE S DIE="^PS(52.6,",DA=PSDELADD,DR="15////"_PSDELOIT D ^DIE K DIE D EN^PSSPOIDT(PSDELOIT),EN2^PSSHL1(PSDELOIT,"MUP")
- QREMAT K PSDELADD,PSDELFLG,PSDELOIT Q
- ;
- REMSS ;Rematch solution to Orderable Item
- I '$G(PSDELSOL)!('$G(PSDELOIS)) G QRESOL
- I $P($G(^PS(52.7,PSDELSOL,0)),"^",11) G QRESOL
- I $P($G(^PS(50.7,+PSDELOIS,0)),"^",3) D
- .K DIE S DIE="^PS(52.7,",DA=PSDELSOL,DR="9////"_PSDELOIS D ^DIE K DIE D EN^PSSPOIDT(PSDELOIS),EN2^PSSHL1(PSDELOIS,"MUP")
- QRESOL K PSDELSOL,PSDELOIS,PSDELSLG Q
- ;
- SELIV ;Ask user to select another IV Additive or Solution.
- K PSSIVOUT
- W ! K DIR S DIR(0)="Y",DIR("A")="Would you like to enter another IV Additive or Solution",DIR("B")="NO" D ^DIR K DIR I Y'=1 S PSSIVOUT=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSSOLIT 3603 printed Jan 18, 2025@03:35:07 Page 2
- PSSSOLIT ;BIR/RTR/WRT-Manual match Solutions to Orderable Items; 09/02/97 8:54
- +1 ;;1.0;PHARMACY DATA MANAGEMENT;**32,41,125**;9/30/97;Build 2
- +2 ;
- EN IF $DATA(PSSIEN)
- LOCK -^PS(52.7,PSSIEN)
- +1 if $GET(PSDELSLG)
- DO REMSS
- if $GET(PSMASTER)
- DO END
- if $GET(PSSSSS)!($GET(PSMASTER))
- QUIT
- DO END
- WRITE !
- SET (PSSOUT,CHANGE,CHKFLAG)=0
- KILL DIC
- SET DIC="^PS(52.7,"
- SET DIC(0)="QEAMZ"
- SET DIC("A")="Select IV SOLUTION: "
- DO ^DIC
- KILL DIC
- if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
- GOTO END
- MAS ;Entry point for Master Drug Enter/Edit
- +1 SET PSSIEN=+Y
- SET PSSNAME=$PIECE(Y,"^",2)
- SET PSDISP=+$PIECE($GET(^PS(52.7,+Y,0)),"^",2)
- SET (PSSOI,PSOLDOI)=+$PIECE($GET(^(0)),"^",11)
- SET PSSVOL=$PIECE($GET(^(0)),"^",3)
- LOCK +^PS(52.7,PSSIEN):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
- IF '$TEST
- WRITE !,$CHAR(7),"Another person is editing this one."
- QUIT
- +2 IF 'PSDISP
- WRITE $CHAR(7),!!?5,"This IV Solution does not point to the Dispense Drug File (#50)",!?5,"it cannot be matched to an Orderable Item!",!
- GOTO EN
- ENTER IF 'PSSOI
- GOTO ^PSSSOLI1
- +1 SET PSOINAME=$PIECE($GET(^PS(50.7,PSSOI,0)),"^")
- SET PSOIDOSE=+$PIECE($GET(^(0)),"^",2)
- WRITE !!,"IV Solution -> ",PSSNAME," ",PSSVOL,!," is already matched to:",!,PSOINAME," ",$PIECE($GET(^PS(50.606,PSOIDOSE,0)),"^")
- +2 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Do you want to re-match this IV Solution"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y'=1
- DO SELIV
- GOTO @$SELECT($GET(PSSJI)&('$GET(PSSIVOUT)):"ENS^PSSVIDRG",1:"EN")
- +3 SET PSDELSLG=1
- SET PSDELSOL=PSSIEN
- SET PSDELOIS=PSSOI
- +4 KILL DIE
- SET DA=PSSIEN
- SET DIE="^PS(52.7,"
- SET DR="9////"_"@"
- DO ^DIE
- KILL DIE
- DO EN^PSSPOIDT(PSSOI)
- DO EN2^PSSHL1(PSSOI,"MUP")
- KILL PSOINAME,PSOIDOSE,PSSOI
- GOTO ^PSSSOLI1
- INACT WRITE !
- KILL DIE
- SET PSBEFORE=$PIECE(^PS(50.7,PSSOI,0),"^",4)
- SET PSAFTER=0
- SET PSINORDE=""
- SET DIE="^PS(50.7,"
- SET DR=".04;.05;.06;.07;.08"
- SET DA=PSSOI
- DO ^DIE
- SET PSAFTER=$PIECE(^PS(50.7,PSSOI,0),"^",4)
- KILL DIE
- +1 if PSBEFORE&('PSAFTER)
- SET PSINORDE="D"
- if PSAFTER
- SET PSINORDE="I"
- +2 IF PSINORDE'=""
- DO REST^PSSPOIDT(PSSOI)
- +3 KILL PSBEFORE,PSAFTER,PSINORDE
- SYN WRITE !
- KILL DIC
- if '$DATA(^PS(50.7,PSSOI,2,0))
- SET ^PS(50.7,PSSOI,2,0)="^50.72^0^0"
- SET DIC="^PS(50.7,"_PSSOI_",2,"
- SET DA(1)=PSSOI
- SET DIC(0)="QEAMLZ"
- SET DIC("A")="Select SYNONYM: "
- SET DLAYGO=50.7
- DO ^DIC
- KILL DIC
- +1 IF Y<0!($DATA(DTOUT))!($DATA(DUOUT))
- if '$ORDER(^PS(50.7,PSSOI,2,0))
- KILL ^PS(50.7,PSSOI,2,0)
- if $GET(NEWFLAG)
- QUIT
- DO EN^PSSPOIDT(PSSOI)
- if '$GET(PSSSSS)
- DO EN2^PSSHL1(PSSOI,"MUP")
- GOTO EN
- +2 WRITE !
- SET DA=+Y
- SET DIE="^PS(50.7,"_PSSOI_",2,"
- SET DA(1)=PSSOI
- SET DR=.01
- DO ^DIE
- KILL DIE
- GOTO SYN
- +3 if $GET(NEWFLAG)
- QUIT
- DO EN^PSSPOIDT(PSSOI)
- if '$GET(PSSSSS)
- DO EN2^PSSHL1(PSSOI,"MUP")
- +4 GOTO EN
- END IF $DATA(PSSIEN)
- LOCK -^PS(52.7,PSSIEN)
- +1 KILL DA,DIC,DIR,PSSIEN,PSSNAME,PSDISP,PSSOI,PSDOSNM,CHANGE,CHKFLAG,DA,DR,DIR,DIE,INFLAG,HOLDOI,INPUT,J,JJ,HOLDNAME,NEWFLAG,PSDOSPTR,PSND,PSND1,PSND3,PSNDOSE,PSOIDOSE,PSOINAME,PSOLDOI,PSONEW,PSOTHER,PSSOUT,PSSVOL,ZZ,ZZZZFLAG,ZZPOI,ZZFLAG
- +2 KILL SS,QQ,WW,PSNEWOI,PPFLAG,VV,VVV,TT,SCLAST,SYN,SYN1,SCOUNT,PSANS,ZZFLAG,ZZXFLAG,PSPOI,SYNNAM,PSDELSOL,PSDELSLG,PSDELOIS,PSSSSS
- QUIT
- +3 QUIT
- REMAT ;Rematch Additive to Orderable Item
- +1 IF '$GET(PSDELADD)!('$GET(PSDELOIT))
- GOTO QREMAT
- +2 IF $PIECE($GET(^PS(52.6,PSDELADD,0)),"^",11)
- GOTO QREMAT
- +3 IF $PIECE($GET(^PS(50.7,+PSDELOIT,0)),"^",3)
- IF '$ORDER(^PS(52.6,"AOI",+PSDELOIT,0))
- Begin DoDot:1
- +4 KILL DIE
- SET DIE="^PS(52.6,"
- SET DA=PSDELADD
- SET DR="15////"_PSDELOIT
- DO ^DIE
- KILL DIE
- DO EN^PSSPOIDT(PSDELOIT)
- DO EN2^PSSHL1(PSDELOIT,"MUP")
- End DoDot:1
- QREMAT KILL PSDELADD,PSDELFLG,PSDELOIT
- QUIT
- +1 ;
- REMSS ;Rematch solution to Orderable Item
- +1 IF '$GET(PSDELSOL)!('$GET(PSDELOIS))
- GOTO QRESOL
- +2 IF $PIECE($GET(^PS(52.7,PSDELSOL,0)),"^",11)
- GOTO QRESOL
- +3 IF $PIECE($GET(^PS(50.7,+PSDELOIS,0)),"^",3)
- Begin DoDot:1
- +4 KILL DIE
- SET DIE="^PS(52.7,"
- SET DA=PSDELSOL
- SET DR="9////"_PSDELOIS
- DO ^DIE
- KILL DIE
- DO EN^PSSPOIDT(PSDELOIS)
- DO EN2^PSSHL1(PSDELOIS,"MUP")
- End DoDot:1
- QRESOL KILL PSDELSOL,PSDELOIS,PSDELSLG
- QUIT
- +1 ;
- SELIV ;Ask user to select another IV Additive or Solution.
- +1 KILL PSSIVOUT
- +2 WRITE !
- KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Would you like to enter another IV Additive or Solution"
- SET DIR("B")="NO"
- DO ^DIR
- KILL DIR
- IF Y'=1
- SET PSSIVOUT=1
- +3 QUIT