PSIVREC ;BIR/CCH,PR-RECOMPILE IV STATS ;16 DEC 97 / 1:40 PM
;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
REC W !,"Enter Name of Drug to be recompiled" R !,"(if multiple names, separate by "",""): ",STR:DTIME W:'$T $C(7) G:'$T!("^"[STR) DONE I STR?1."?" S HELP="OMP" D ^PSIVHLP2 G REC
S (ADDSTR,SOLSTR)="" F Z=1:1:$L(STR,",") S NM=$P(STR,",",Z) D LOOKUP I 'ADDSTR,'SOLSTR W ! G REC
QUE S ZTRTN="ENQ^PSIVREC",ZTIO="",ZTDTH=$H,ZTDESC="Recompile IV Stats"
F G="I7","I8","ADDSTR","SOLSTR" S ZTSAVE(G)=""
D ^%ZTLOAD W:$D(ZTSK) !,"Queued."
DONE K %DT,ADDSTR,COST,D,DA,DAT,DATA,FLE,G,HELP,IV,NM,PCE,I7,I8,SOLSTR,STR,X,Y,Z,ZTSK,C D ENIVKV^PSGSETU Q
LOOKUP W !,NM K DIC S X=NM,DIC(0)="EZ",DIC="^PS(52.6,",DIC("W")="W "" (Additive)""" D ^DIC
I Y'>0 S DIC="^PS(52.7,",DIC("W")="W $P(^(0),U,3),"" SOLUTION""",X=NM D ^DIC I Y'>0 K DIC W !!,NM_" NOT FOUND" Q
FOUND W !,$P(Y(0),"^")_" in the "_$S(DIC[52.6:"Additive",1:"Solution")_" File"
I DIC[52.6 S ADDSTR=$S('ADDSTR:+Y,1:ADDSTR_","_+Y)
E S SOLSTR=$S('SOLSTR:+Y,1:SOLSTR_","_+Y)
K DIC Q
ENQ ; done as background job to fix correct cost in stats file 50.8
F IV=0:0 S IV=$O(^PS(50.8,IV)) Q:'IV I $D(^PS(50.8,IV,2)) F DAT=I7-1:0 S DAT=$O(^PS(50.8,IV,2,DAT)) Q:'DAT!(DAT>I8) D FNDRG
D DONE S:$D(ZTQUEUED) ZTREQ="@" Q
FNDRG Q:'$D(^PS(50.8,IV,2,DAT,2)) I ADDSTR S FLE=52.6 F PCE=1:1:$L(ADDSTR,",") S D=$P(ADDSTR,",",PCE) D FIX
I SOLSTR S FLE=52.7 F PCE=1:1:$L(SOLSTR,",") S D=$P(SOLSTR,",",PCE) D FIX
Q
FIX I $D(^PS(50.8,IV,2,DAT,2,"AC",FLE,D)) S DA=$O(^(D,0)),COST=$P(^PS(FLE,D,0),"^",7),$P(^PS(50.8,IV,2,DAT,2,DA,0),"^",5)=COST Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVREC 1600 printed Dec 13, 2024@02:04:57 Page 2
PSIVREC ;BIR/CCH,PR-RECOMPILE IV STATS ;16 DEC 97 / 1:40 PM
+1 ;;5.0; INPATIENT MEDICATIONS ;;16 DEC 97
REC WRITE !,"Enter Name of Drug to be recompiled"
READ !,"(if multiple names, separate by "",""): ",STR:DTIME
if '$TEST
WRITE $CHAR(7)
if '$TEST!("^"[STR)
GOTO DONE
IF STR?1."?"
SET HELP="OMP"
DO ^PSIVHLP2
GOTO REC
+1 SET (ADDSTR,SOLSTR)=""
FOR Z=1:1:$LENGTH(STR,",")
SET NM=$PIECE(STR,",",Z)
DO LOOKUP
IF 'ADDSTR
IF 'SOLSTR
WRITE !
GOTO REC
QUE SET ZTRTN="ENQ^PSIVREC"
SET ZTIO=""
SET ZTDTH=$HOROLOG
SET ZTDESC="Recompile IV Stats"
+1 FOR G="I7","I8","ADDSTR","SOLSTR"
SET ZTSAVE(G)=""
+2 DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Queued."
DONE KILL %DT,ADDSTR,COST,D,DA,DAT,DATA,FLE,G,HELP,IV,NM,PCE,I7,I8,SOLSTR,STR,X,Y,Z,ZTSK,C
DO ENIVKV^PSGSETU
QUIT
LOOKUP WRITE !,NM
KILL DIC
SET X=NM
SET DIC(0)="EZ"
SET DIC="^PS(52.6,"
SET DIC("W")="W "" (Additive)"""
DO ^DIC
+1 IF Y'>0
SET DIC="^PS(52.7,"
SET DIC("W")="W $P(^(0),U,3),"" SOLUTION"""
SET X=NM
DO ^DIC
IF Y'>0
KILL DIC
WRITE !!,NM_" NOT FOUND"
QUIT
FOUND WRITE !,$PIECE(Y(0),"^")_" in the "_$SELECT(DIC[52.6:"Additive",1:"Solution")_" File"
+1 IF DIC[52.6
SET ADDSTR=$SELECT('ADDSTR:+Y,1:ADDSTR_","_+Y)
+2 IF '$TEST
SET SOLSTR=$SELECT('SOLSTR:+Y,1:SOLSTR_","_+Y)
+3 KILL DIC
QUIT
ENQ ; done as background job to fix correct cost in stats file 50.8
+1 FOR IV=0:0
SET IV=$ORDER(^PS(50.8,IV))
if 'IV
QUIT
IF $DATA(^PS(50.8,IV,2))
FOR DAT=I7-1:0
SET DAT=$ORDER(^PS(50.8,IV,2,DAT))
if 'DAT!(DAT>I8)
QUIT
DO FNDRG
+2 DO DONE
if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
FNDRG if '$DATA(^PS(50.8,IV,2,DAT,2))
QUIT
IF ADDSTR
SET FLE=52.6
FOR PCE=1:1:$LENGTH(ADDSTR,",")
SET D=$PIECE(ADDSTR,",",PCE)
DO FIX
+1 IF SOLSTR
SET FLE=52.7
FOR PCE=1:1:$LENGTH(SOLSTR,",")
SET D=$PIECE(SOLSTR,",",PCE)
DO FIX
+2 QUIT
FIX IF $DATA(^PS(50.8,IV,2,DAT,2,"AC",FLE,D))
SET DA=$ORDER(^(D,0))
SET COST=$PIECE(^PS(FLE,D,0),"^",7)
SET $PIECE(^PS(50.8,IV,2,DAT,2,DA,0),"^",5)=COST
QUIT
