Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APSQBEG

APSQBEG.m

Go to the documentation of this file.
  1. APSQBEG ;IHS/ASDS/ENM/POC - ROUTINE TO START INIT
  1. ;;6.0;IHS PHARMACY MODIFICATIONS;**3**;FEB 20, 2001
  1. D ^APSQINIT
  1. D POST^APSQCK
  1. D RTN
  1. Q
  1. S PACKAGE="DFDFDF"
  1. W !,"DELETING PACKAGE "_PACKAGE
  1. S X=$O(^DIC(9.4,"B",PACKAGE,""))
  1. D:$G(X)'=""
  1. .S DA=X,DIK="^DIK(9.4," D ^DIK K DIK
  1. K PACKAGE,X
  1. RTN ;
  1. F II=1:1 S LINE=$P($T(INITD+II),";;",2) Q:LINE="END" D
  1. .F JJ=1:1 S RTN=$P(LINE,",",JJ) Q:RTN="" D
  1. ..S X=RTN X ^%ZOSF("DEL")
  1. ..W !,RTN," GONE!"
  1. K II,JJ,RTN,LINE
  1. Q
  1. INITD ;RTNS TO DELETE
  1. ;;APSQI001,APSQI002,APSQI003,APSQI004,APSQI005,APSQI006,APSQI007
  1. ;;APSQI008,APSQI009,APSQI00A,APSQI00B,APSQI00C,APSQI00D,APSQI00E
  1. ;;APSQI00F,APSQI00G,APSQI00H,APSQI00I,APSQI00J,APSQI00K,APSQI00L
  1. ;;APSQI00M,APSQI00N,APSQINI1,APSQINI2,APSQINI3,APSQINI4,APSQINI5
  1. ;;APSQINIT,APSQI00O,APSQI00P
  1. ;;END
  1. Q
  1. ;
  1. ADLN ;ADD LINES TO ROUTINES PSODRG,PSON52,PSORN52,PSORXDL,PSORXI
  1. ;DO NOT ADD ENTRY TO INTERVENTION FILE FOR NON FORMULARY ITEM-ALREAY 10
  1. S DIC="^DIC(9.4,",X="PSO",DIC(0)="MX"
  1. D ^DIC K DIC
  1. I Y<1 W !,"WHERE IS PACKAGE PACKAGE-SOMETHING WRONG" D END Q
  1. S X=+$G(^DIC(9.4,+Y,"VERSION"))
  1. I X'[6.0 W !,"NOT THE RIGHT VERSION?" D END Q
  1. F X="PSODRG","PSON52","PSORN52","PSORXDL","PSORXI" D
  1. .S RTN=X
  1. .X ^%ZOSF("TEST") I '$T W !,"ROUTINE ",X," DOES NOT EXIST-??" Q
  1. .K ^UTILITY("SCRATCH",$J),QUIT
  1. .;LOAD PORTION TO A UTILITY GLOBAL
  1. .S XCNP=0,DIF="^UTILITY(""SCRATCH"",$J,"
  1. .X ^%ZOSF("LOAD")
  1. .;NOW CHECK
  1. .S STOP=0
  1. .;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
  1. .;
  1. .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
  1. .I STOP D END Q
  1. .;
  1. .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
  1. .I $G(CHECKIT)']"" D END Q
  1. .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
  1. .I $G(CHECKPUT)']"" D END Q
  1. .F JJ=1:1 S TEXT=$P($T(TEXT+JJ),";;",2) Q:TEXT="END" D
  1. ..Q:$P(TEXT,"~",1)'=RTN
  1. ..S ^UTILITY("SCRATCH",$J,CHECKPUT_$P(TEXT,"~",2),0)=$P(TEXT,"~",3)
  1. .;SAVE BACK AS ROUTINE
  1. .S X=RTN,XCN=0,DIE="^UTILITY(""SCRATCH"",$J,"
  1. .X ^%ZOSF("SAVE")
  1. .K ^UTILITY("SCRATCH",$J)
  1. .K CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT
  1. .W !,"ROUTINE ",RTN," HAS BEEN MODIFIED!!"
  1. .Q
  1. ;Q
  1. ;
  1. END ;
  1. K ^UTILITY("SCRATCH",$J)
  1. K CHECKIT,CHECK,CHECKIEN,STOP,CHECKPUT,TEXT,TEXTCH,%,%N,XCNP,RTN,DIF
  1. K DIC,DA,JJ,KK,DIE,STOP,X,Y
  1. Q
  1. ;
  1. TEXT ;;
  1. ;;PSODRG~.1~ D POSTX ;IHS/OKCAO/POC 9/28/98
  1. ;;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
  1. ;;PSODRG~.3~ D POSTX ;IHS/OKCAO/POC 9/28/98
  1. ;;PSON52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
  1. ;;PSORN52~.1~ S X="APSQCK" X ^%ZOSF("TEST") I $T S NFRXIEN=PSOX("IRXN") D RXSET^APSQCK ;IHS/OKCAO/POC 9/28/98
  1. ;;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
  1. ;;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
  1. ;;END
  1. ;
  1. TEXTCH ;;
  1. ;;PSODRG~D:$P($G(^PSDRUG(PSODRUG("IEN"),"CLOZ1")),"^")]""
  1. ;;PSON52~D EOJ
  1. ;;PSORN52~D EOJ
  1. ;;PSORXDL~I $G(^PSRX(DA,"H"))]"" K ^PSRX("AH",
  1. ;;PSORXI~D FILE^DICN K DIC,DR,DA
  1. ;;END