APSQBEG ;IHS/ASDS/ENM/POC - ROUTINE TO START INIT
;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
D ^APSQINIT
D POST^APSQCK
D RTN
Q
S PACKAGE="DFDFDF"
W !,"DELETING PACKAGE "_PACKAGE
S X=$O(^DIC(9.4,"B",PACKAGE,""))
D:$G(X)'=""
.S DA=X,DIK="^DIK(9.4," D ^DIK K DIK
K PACKAGE,X
RTN ;
F II=1:1 S LINE=$P($T(INITD+II),";;",2) Q:LINE="END" D
.F JJ=1:1 S RTN=$P(LINE,",",JJ) Q:RTN="" D
..S X=RTN X ^%ZOSF("DEL")
..W !,RTN," GONE!"
K II,JJ,RTN,LINE
Q
INITD ;RTNS TO DELETE
;;APSQI001,APSQI002,APSQI003,APSQI004,APSQI005,APSQI006,APSQI007
;;APSQI008,APSQI009,APSQI00A,APSQI00B,APSQI00C,APSQI00D,APSQI00E
;;APSQI00F,APSQI00G,APSQI00H,APSQI00I,APSQI00J,APSQI00K,APSQI00L
;;APSQI00M,APSQI00N,APSQINI1,APSQINI2,APSQINI3,APSQINI4,APSQINI5
;;APSQINIT,APSQI00O,APSQI00P
;;END
Q
;
ADLN ;ADD LINES TO ROUTINES PSODRG,PSON52,PSORN52,PSORXDL,PSORXI
;DO NOT ADD ENTRY TO INTERVENTION FILE FOR NON FORMULARY ITEM-ALREAY 10
S DIC="^DIC(9.4,",X="PSO",DIC(0)="MX"
D ^DIC K DIC
I Y<1 W !,"WHERE IS PACKAGE PACKAGE-SOMETHING WRONG" D END Q
S X=+$G(^DIC(9.4,+Y,"VERSION"))
I X'[6.0 W !,"NOT THE RIGHT VERSION?" D END Q
F X="PSODRG","PSON52","PSORN52","PSORXDL","PSORXI" D
.S RTN=X
.X ^%ZOSF("TEST") I '$T W !,"ROUTINE ",X," DOES NOT EXIST-??" Q
.K ^UTILITY("SCRATCH",$J),QUIT
.;LOAD PORTION TO A UTILITY GLOBAL
.S XCNP=0,DIF="^UTILITY(""SCRATCH"",$J,"
.X ^%ZOSF("LOAD")
.;NOW CHECK
.S STOP=0
.;S CHECKIEN="" F S CHECKIEN=$O(^UTILITY("SCRATCH",$J,CHECKIEN)) Q:CHECKIEN="" S CHECK=^(CHECKIEN,0) I CHECK["S X=""APSQCK""" W !,"ROUTINE ",RTN," ALREADY CONTAINS A REFERENCE TO 'APSQCK'" S STOP=1 Q
.;
.S CHECKIEN="" F S CHECKIEN=$O(^UTILITY("SCRATCH",$J,CHECKIEN)) Q:CHECKIEN="" S CHECK=^(CHECKIEN,0) I CHECK[$S(RTN="PSORXI":"$G(PSORX(""INTERVENE""))=4",1:"S X=""APSQCK""") W !,"ROUTINE ",RTN," ALREADY CONTAINS A REF TO 'APSQCK'" S STOP=1 Q
.I STOP D END Q
.;
.F KK=1:1 S TEXTCH=$P($T(TEXTCH+KK),";;",2) Q:TEXTCH="END" I $P(TEXTCH,"~",1)=RTN S CHECKIT=$P(TEXTCH,"~",2) Q
.I $G(CHECKIT)']"" D END Q
.S CHECKIEN="" F S CHECKIEN=$O(^UTILITY("SCRATCH",$J,CHECKIEN)) Q:CHECKIEN="" S CHECK=^(CHECKIEN,0) I CHECK[CHECKIT S CHECKPUT=$O(^UTILITY("SCRATCH",$J,CHECKIEN),-1) Q
.I $G(CHECKPUT)']"" D END Q
.F JJ=1:1 S TEXT=$P($T(TEXT+JJ),";;",2) Q:TEXT="END" D
..Q:$P(TEXT,"~",1)'=RTN
..S ^UTILITY("SCRATCH",$J,CHECKPUT_$P(TEXT,"~",2),0)=$P(TEXT,"~",3)
.;SAVE BACK AS ROUTINE
.S X=RTN,XCN=0,DIE="^UTILITY(""SCRATCH"",$J,"
.X ^%ZOSF("SAVE")
.K ^UTILITY("SCRATCH",$J)
.K CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT
.W !,"ROUTINE ",RTN," HAS BEEN MODIFIED!!"
.Q
;Q
;
END ;
K ^UTILITY("SCRATCH",$J)
K CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT,TEXT,TEXTCH,%,%N,XCNP,RTN,DIF
K DIC,DA,JJ,KK,DIE,STOP,X,Y
Q
;
TEXT ;;
;;PSODRG~.1~ D POSTX ;IHS/OKCAO/POC 9/28/98
;;PSODRG~.2~ S X="APSQCK" X ^%ZOSF("TEST") I $T D RX^APSQCK D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/OKCAO/POC 9/28/98
;;PSODRG~.3~ D POSTX ;IHS/OKCAO/POC 9/28/98
;;PSON52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
;;PSORN52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
;;PSORXDL~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=DA D RXSETK^APSQCK ;IHS/OKCAO/POC 928/98 DELETE PRESCRIPTION FIELD IN FILE NON FORMULARY REQUEST
;;PSORXI~.1~ S DIC("DR")=DIC("DR")_$S($G(PSORX("INTERVENE"))=1:";.07////"_APSPCRI,$G(PSORX("INTERVENE"))=2:";.07////"_APSPSIG,$G(PSORX("INTERVENE"))=3:";.07////6",$G(PSORX("INTERVENE"))=4:";.07////10",1:"")_";.14////0"_";.16////"_$S($G(PSOSITE)]"":PSOSITE,1:"") ;IHS/DSD ENM POC 05/08/98 IHS/OKCAO/POC 928/98 ADDED NON FORMULARY REQUEST
;;END
;
TEXTCH ;;
;;PSODRG~D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]""
;;PSON52~D EOJ
;;PSORN52~D EOJ
;;PSORXDL~I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",
;;PSORXI~D FILE^DICN K DIC,DR,DA
;;END
APSQBEG ;IHS/ASDS/ENM/POC - ROUTINE TO START INIT
+1 ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
+2 DO ^APSQINIT
+3 DO POST^APSQCK
+4 DO RTN
+5 QUIT
+6 SET PACKAGE="DFDFDF"
+7 WRITE !,"DELETING PACKAGE "_PACKAGE
+8 SET X=$ORDER(^DIC(9.4,"B",PACKAGE,""))
+9 IF $GET(X)'=""
Begin DoDot:1
+10 SET DA=X
SET DIK="^DIK(9.4,"
DO ^DIK
KILL DIK
End DoDot:1
+11 KILL PACKAGE,X
RTN ;
+1 FOR II=1:1
SET LINE=$PIECE($TEXT(INITD+II),";;",2)
IF LINE="END"
QUIT
Begin DoDot:1
+2 FOR JJ=1:1
SET RTN=$PIECE(LINE,",",JJ)
IF RTN=""
QUIT
Begin DoDot:2
+3 SET X=RTN
XECUTE ^%ZOSF("DEL")
+4 WRITE !,RTN," GONE!"
End DoDot:2
End DoDot:1
+5 KILL II,JJ,RTN,LINE
+6 QUIT
INITD ;RTNS TO DELETE
+1 ;;APSQI001,APSQI002,APSQI003,APSQI004,APSQI005,APSQI006,APSQI007
+2 ;;APSQI008,APSQI009,APSQI00A,APSQI00B,APSQI00C,APSQI00D,APSQI00E
+3 ;;APSQI00F,APSQI00G,APSQI00H,APSQI00I,APSQI00J,APSQI00K,APSQI00L
+4 ;;APSQI00M,APSQI00N,APSQINI1,APSQINI2,APSQINI3,APSQINI4,APSQINI5
+5 ;;APSQINIT,APSQI00O,APSQI00P
+6 ;;END
+7 QUIT
+8 ;
ADLN ;ADD LINES TO ROUTINES PSODRG,PSON52,PSORN52,PSORXDL,PSORXI
+1 ;DO NOT ADD ENTRY TO INTERVENTION FILE FOR NON FORMULARY ITEM-ALREAY 10
+2 SET DIC="^DIC(9.4,"
SET X="PSO"
SET DIC(0)="MX"
+3 DO ^DIC
KILL DIC
+4 IF Y<1
WRITE !,"WHERE IS PACKAGE PACKAGE-SOMETHING WRONG"
DO END
QUIT
+5 SET X=+$GET(^DIC(9.4,+Y,"VERSION"))
+6 IF X'[6.0
WRITE !,"NOT THE RIGHT VERSION?"
DO END
QUIT
+7 FOR X="PSODRG","PSON52","PSORN52","PSORXDL","PSORXI"
Begin DoDot:1
+8 SET RTN=X
+9 XECUTE ^%ZOSF("TEST")
IF '$TEST
WRITE !,"ROUTINE ",X," DOES NOT EXIST-??"
QUIT
+10 KILL ^UTILITY("SCRATCH",$JOB),QUIT
+11 ;LOAD PORTION TO A UTILITY GLOBAL
+12 SET XCNP=0
SET DIF="^UTILITY(""SCRATCH"",$J,"
+13 XECUTE ^%ZOSF("LOAD")
+14 ;NOW CHECK
+15 SET STOP=0
+16 ;S CHECKIEN="" F S CHECKIEN=$O(^UTILITY("SCRATCH",$J,CHECKIEN)) Q:CHECKIEN="" S CHECK=^(CHECKIEN,0) I CHECK["S X=""APSQCK""" W !,"ROUTINE ",RTN," ALREADY CONTAINS A REFERENCE TO 'APSQCK'" S STOP=1 Q
+17 ;
+18 SET CHECKIEN=""
FOR
SET CHECKIEN=$ORDER(^UTILITY("SCRATCH",$JOB,CHECKIEN))
IF CHECKIEN=""
QUIT
SET CHECK=^(CHECKIEN,0)
IF CHECK[$SELECT(RTN="PSORXI":"$G(PSORX(""INTERVENE""))=4",1:"S X=""APSQCK""")
WRITE !,"ROUTINE ",RTN," ALREADY CONTAINS A REF TO 'APSQCK'"
SET STOP=1
QUIT
+19 IF STOP
DO END
QUIT
+20 ;
+21 FOR KK=1:1
SET TEXTCH=$PIECE($TEXT(TEXTCH+KK),";;",2)
IF TEXTCH="END"
QUIT
IF $PIECE(TEXTCH,"~",1)=RTN
SET CHECKIT=$PIECE(TEXTCH,"~",2)
QUIT
+22 IF $GET(CHECKIT)']""
DO END
QUIT
+23 SET CHECKIEN=""
FOR
SET CHECKIEN=$ORDER(^UTILITY("SCRATCH",$JOB,CHECKIEN))
IF CHECKIEN=""
QUIT
SET CHECK=^(CHECKIEN,0)
IF CHECK[CHECKIT
SET CHECKPUT=$ORDER(^UTILITY("SCRATCH",$JOB,CHECKIEN),-1)
QUIT
+24 IF $GET(CHECKPUT)']""
DO END
QUIT
+25 FOR JJ=1:1
SET TEXT=$PIECE($TEXT(TEXT+JJ),";;",2)
IF TEXT="END"
QUIT
Begin DoDot:2
+26 IF $PIECE(TEXT,"~",1)'=RTN
QUIT
+27 SET ^UTILITY("SCRATCH",$JOB,CHECKPUT_$PIECE(TEXT,"~",2),0)=$PIECE(TEXT,"~",3)
End DoDot:2
+28 ;SAVE BACK AS ROUTINE
+29 SET X=RTN
SET XCN=0
SET DIE="^UTILITY(""SCRATCH"",$J,"
+30 XECUTE ^%ZOSF("SAVE")
+31 KILL ^UTILITY("SCRATCH",$JOB)
+32 KILL CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT
+33 WRITE !,"ROUTINE ",RTN," HAS BEEN MODIFIED!!"
+34 QUIT
End DoDot:1
+35 ;Q
+36 ;
END ;
+1 KILL ^UTILITY("SCRATCH",$JOB)
+2 KILL CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT,TEXT,TEXTCH,%,%N,XCNP,RTN,DIF
+3 KILL DIC,DA,JJ,KK,DIE,STOP,X,Y
+4 QUIT
+5 ;
TEXT ;;
+1 ;;PSODRG~.1~ D POSTX ;IHS/OKCAO/POC 9/28/98
+2 ;;PSODRG~.2~ S X="APSQCK" X ^%ZOSF("TEST") I $T D RX^APSQCK D:$G(PSORX("INTERVENE"))]"" ^PSORXI G:PSORX("DFLG") POSTX ;IHS/OKCAO/POC 9/28/98
+3 ;;PSODRG~.3~ D POSTX ;IHS/OKCAO/POC 9/28/98
+4 ;;PSON52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
+5 ;;PSORN52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
+6 ;;PSORXDL~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=DA D RXSETK^APSQCK ;IHS/OKCAO/POC 928/98 DELETE PRESCRIPTION FIELD IN FILE NON FORMULARY REQUEST
+7 ;;PSORXI~.1~ S DIC("DR")=DIC("DR")_$S($G(PSORX("INTERVENE"))=1:";.07////"_APSPCRI,$G(PSORX("INTERVENE"))=2:";.07////"_APSPSIG,$G(PSORX("INTERVENE"))=3:";.07////6",$G(PSORX("INTERVENE"))=4:";.07////10",1:"")_";.14////0"_";.16////"_$S($G(PSOSITE)]
"":PSOSITE,1:"") ;IHS/DSD ENM POC 05/08/98 IHS/OKCAO/POC 928/98 ADDED NON FORMULARY REQUEST
+8 ;;END
+9 ;
TEXTCH ;;
+1 ;;PSODRG~D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]""
+2 ;;PSON52~D EOJ
+3 ;;PSORN52~D EOJ
+4 ;;PSORXDL~I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",
+5 ;;PSORXI~D FILE^DICN K DIC,DR,DA
+6 ;;END
