- 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