PSIVREC.m

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

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