AQAOPOS1 ; IHS/ORDC/LJF - POST INIT ;
;;1.01;QAI MANAGEMENT;;OCT 05, 1995
;
;This is a continuation of postinits. Installs
;indicators sent with the package, then calls ^AQAOPOS2.
;
2 ; step 2 - install indicators sent with pkg
W !!,"STEP 2 - INSTALL INDICATORS DISTRIBUTED WITH PACKAGE",!!
W !,"I will install any indicator you do not already have PLUS"
W !,"those you do have but which are inactive.",!!
;
;want to update inactive ind?
I $O(^AQAO(2,0)) S AQAOUPD=$$INACT I AQAOUPD=U!(AQAOUPD="")!(AQAOUPD="N") G NEXT
;
; loop thru indicators in scratch file
S AQAOX=0 L +^AQAO(2,0):1
I '$T W !!,"INDICATOR FILE LOCKED! BYPASSING STEP 2!",!! G NEXT
F S AQAOX=$O(^AQAOXX(2,AQAOX)) Q:AQAOX'=+AQAOX D
.S AQAOID=$P(^AQAOXX(2,AQAOX,0),U)
.; if ind exists & inactive, ok to update?
.I $D(^AQAO(2,"B",AQAOID)) D Q:$G(AQAONUPD)=U
..S DA=$O(^AQAO(2,"B",AQAOID,0)) Q:DA="" ;bad xref
..I $P($G(^AQAO(2,DA,0)),U,6)'="I" S AQAONUPD=U Q ;do not update active ind
..I AQAOUPD="S" S AQAONUPD=$$UPD Q:AQAONUPD=U ;not ok to update
..S DIE="^AQAO(2,",DR=$$DRSET D ^DIE S Y=DA ;update ind
.;
.E D ; else create entry
..K DIC,DD,DO S DIC="^AQAO(2,",DIC(0)="L",DLAYGO=9002164
..S X=AQAOID,DIC("DR")=$$DRSET ;set dr string from gbl
..D FILE^DICN Q:Y=-1
.;
.S AQAOIFN=+Y,AQAOCNT=0 ;set descrip wp field
.F S AQAOCNT=$O(^AQAOXX(2,AQAOX,"D",AQAOCNT)) Q:AQAOCNT="" D
..S ^AQAO(2,AQAOIFN,"D",AQAOCNT,0)=^AQAOXX(2,AQAOX,"D",AQAOCNT,0)
.S ^AQAO(2,AQAOIFN,"D",0)=U_U_AQAOCNT_U_AQAOCNT_U_DT
.;
.S AQAOCNT=0 ;set methodology wp field
.F S AQAOCNT=$O(^AQAOXX(2,AQAOX,"M",AQAOCNT)) Q:AQAOCNT="" D
..S ^AQAO(2,AQAOIFN,"M",AQAOCNT,0)=^AQAOXX(2,AQAOX,"M",AQAOCNT,0)
.S ^AQAO(2,AQAOIFN,"M",0)=U_U_AQAOCNT_U_AQAOCNT_U_DT
.;
.;install review criteria for ind
.Q:'$D(^AQAOXX(6,"C",AQAOX)) ;no crit for ind
.D CRIT ;install crit & ind links
;
L -^AQAO(2,0)
NEXT ; go to next rtn for more
D ^AQAOPOS2 Q
;
;
CRIT ; SUBRTN to install criteria for ind
L +^AQAO1(6,0):1 I '$T W !!,"QI REVIEW CRITERIA file locked!" Q
L +^AQAO1(4,0):1 I '$T W !!,"QI CRITERIA CODES file locked" Q
;
S AQAOC=0 ;get all crit for ind,add to site's file
F S AQAOC=$O(^AQAOXX(6,"C",AQAOX,AQAOC)) Q:AQAOC="" D
.Q:'$D(^AQAOXX(6,AQAOC,0)) S AQAOS=^(0)
.;
.; if crit doesn't exist, add it
.I '$D(^AQAO1(6,"B",$E($P(AQAOS,U),1,30))) D
..K DD,DO,DIC S DIC="^AQAO1(6,",DIC(0)="L",X=$P(AQAOS,U)
..S DIC("DR")=".02////"_$P(AQAOS,U,2)_";.03////"_$P(AQAOS,U,3)_";.04////"_$P(AQAOS,U,4)
..S DLAYGO=9002169 D FILE^DICN K DLAYGO
..I Y=-1 W !!,"Can't ADD ",$P(^AQAOXX(6,AQAOC,0),U)," as criterion." Q
..S AQAOCIFN=+Y
..;
..S AQAOCD=0 ;add any crit codes, if any
..F S AQAOCD=$O(^AQAOXX(6,AQAOC,"CD",AQAOCD)) Q:AQAOCD'=+AQAOCD D
...Q:'$D(^AQAOXX(6,AQAOC,"CD",AQAOCD,0)) S AQAOCOD=^(0)
...S AQAOSS=$G(^AQAOXX(4,AQAOCOD,0))
...S AQAOCODN=$$CODE Q:AQAOCODN=U ;get code,create if needed
...I '$D(^AQAO1(6,AQAOCIFN,"CD",0)) S ^(0)="^9002169.61P^^"
...S DIC="^AQAO1(6,"_AQAOCIFN_",""CD"",",DA(1)=AQAOCIFN
...S DIC(0)="L",X=AQAOCODN D ^DIC
.;
.; link indicator to crit entry
.S AQAOCIFN=$O(^AQAO1(6,"B",$E($P(AQAOS,U),1,30),0)) Q:AQAOCIFN=""
.Q:$D(^AQAO1(6,"C",AQAOIFN,AQAOCIFN)) ;already linked
.I '$D(^AQAO1(6,AQAOCIFN,"IND",0)) S ^(0)="^9002169.699P^^"
.S DIC="^AQAO1(6,"_AQAOCIFN_",""IND"",",DA(1)=AQAOCIFN
.S DIC(0)="L",X=$P(^AQAO(2,AQAOIFN,0),U) D FILE^DICN
L -^AQAO1(6,0) L -^AQAO1(4,0)
Q
;
;
CODE() ; EXTR VAR to add crit codes to file
N X,DD,DO,DIC,Y,DLAYGO
S X=$O(^AQAO1(4,"B",$E($P(AQAOSS,U),1,30),0)) I X="" S Y=""
I X]"",($P(AQAOSS,U,2)'=$P(^AQAO1(4,X,0),U,2)) S Y=""
I $D(Y) D
.S DIC="^AQAO1(4,",DIC(0)="L",DLAYGO=9002169
.S X=$P(AQAOSS,U),DIC("DR")=".02////"_$P(AQAOSS,U,2)
.K DD,DO D FILE^DICN S:Y=-1 X=U
Q X
;
;
INACT() ;EXTR VAR to ask if updating ind is allowed
N Y,DIR
S DIR(0)="SB^N:NONE;S:SELECTED;A:ALL"
S DIR("A",1)="You already have indicators in your file. If I find"
S DIR("A",2)="any that match those I sent with this package, I will"
S DIR("A",3)="UPDATE them if they have been inactivated. You can"
S DIR("A",4)="choose from: NONE - do not update any"
S DIR("A",5)=" SELECTED - I will ask about each one"
S DIR("A",6)=" ALL - update all without further discussion"
S DIR("A")="UPDATE INACTIVE INDICATORS?" D ^DIR
Q Y
;
;
UPD() ;EXTR VAR to ask if user wants indicator updated
N X,Y,DIR
S DIR(0)="Y",DIR("B")="YES"
S DIR("A",1)="You already have "_AQAOID_" as an inactive indicator."
S DIR("A")="Do you want to update this indicator" D ^DIR
S X=$S(Y=1:1,1:U)
Q X
;
;
DRSET() ;EXTR VAR to set dr string
N X,Y S DR=""
S X=^AQAOXX(2,AQAOX,0) ;zero node data
F J=1:1 S Y=$P($T(DATA2+J),";;",2) Q:Y="" D
.S Z=$P($T(DATA2+J),";;",3)
.S DR=DR_";"_Y_"////"_$P(X,U,Z)
S X=^AQAOXX(2,AQAOX,1) ;one node data
F J=1:1 S Y=$P($T(DATA2A+J),";;",2) Q:Y="" D
.S Z=$P($T(DATA2A+J),";;",3)
.S DR=DR_";"_Y_"////"_$P(X,U,Z)
S DR=$E(DR,2,250)_";.06////I"
Q DR
;
;
DATA2 ;; data for step 2 drset extr var
;;.02;;2
;;.03;;3
;;.04;;4
;;.05;;5
;
DATA2A ;; data for step 2 drset extr var second loop
;;.11;;1
;;.12;;2
AQAOPOS1 ; IHS/ORDC/LJF - POST INIT ;
+1 ;;1.01;QAI MANAGEMENT;;OCT 05, 1995
+2 ;
+3 ;This is a continuation of postinits. Installs
+4 ;indicators sent with the package, then calls ^AQAOPOS2.
+5 ;
2 ; step 2 - install indicators sent with pkg
+1 WRITE !!,"STEP 2 - INSTALL INDICATORS DISTRIBUTED WITH PACKAGE",!!
+2 WRITE !,"I will install any indicator you do not already have PLUS"
+3 WRITE !,"those you do have but which are inactive.",!!
+4 ;
+5 ;want to update inactive ind?
+6 IF $ORDER(^AQAO(2,0))
SET AQAOUPD=$$INACT
IF AQAOUPD=U!(AQAOUPD="")!(AQAOUPD="N")
GOTO NEXT
+7 ;
+8 ; loop thru indicators in scratch file
+9 SET AQAOX=0
LOCK +^AQAO(2,0):1
+10 IF '$TEST
WRITE !!,"INDICATOR FILE LOCKED! BYPASSING STEP 2!",!!
GOTO NEXT
+11 FOR
SET AQAOX=$ORDER(^AQAOXX(2,AQAOX))
IF AQAOX'=+AQAOX
QUIT
Begin DoDot:1
+12 SET AQAOID=$PIECE(^AQAOXX(2,AQAOX,0),U)
+13 ; if ind exists & inactive, ok to update?
+14 IF $DATA(^AQAO(2,"B",AQAOID))
Begin DoDot:2
+15 ;bad xref
SET DA=$ORDER(^AQAO(2,"B",AQAOID,0))
IF DA=""
QUIT
+16 ;do not update active ind
IF $PIECE($GET(^AQAO(2,DA,0)),U,6)'="I"
SET AQAONUPD=U
QUIT
+17 ;not ok to update
IF AQAOUPD="S"
SET AQAONUPD=$$UPD
IF AQAONUPD=U
QUIT
+18 ;update ind
SET DIE="^AQAO(2,"
SET DR=$$DRSET
DO ^DIE
SET Y=DA
End DoDot:2
IF $GET(AQAONUPD)=U
QUIT
+19 ;
+20 ; else create entry
IF '$TEST
Begin DoDot:2
+21 KILL DIC,DD,DO
SET DIC="^AQAO(2,"
SET DIC(0)="L"
SET DLAYGO=9002164
+22 ;set dr string from gbl
SET X=AQAOID
SET DIC("DR")=$$DRSET
+23 DO FILE^DICN
IF Y=-1
QUIT
End DoDot:2
+24 ;
+25 ;set descrip wp field
SET AQAOIFN=+Y
SET AQAOCNT=0
+26 FOR
SET AQAOCNT=$ORDER(^AQAOXX(2,AQAOX,"D",AQAOCNT))
IF AQAOCNT=""
QUIT
Begin DoDot:2
+27 SET ^AQAO(2,AQAOIFN,"D",AQAOCNT,0)=^AQAOXX(2,AQAOX,"D",AQAOCNT,0)
End DoDot:2
+28 SET ^AQAO(2,AQAOIFN,"D",0)=U_U_AQAOCNT_U_AQAOCNT_U_DT
+29 ;
+30 ;set methodology wp field
SET AQAOCNT=0
+31 FOR
SET AQAOCNT=$ORDER(^AQAOXX(2,AQAOX,"M",AQAOCNT))
IF AQAOCNT=""
QUIT
Begin DoDot:2
+32 SET ^AQAO(2,AQAOIFN,"M",AQAOCNT,0)=^AQAOXX(2,AQAOX,"M",AQAOCNT,0)
End DoDot:2
+33 SET ^AQAO(2,AQAOIFN,"M",0)=U_U_AQAOCNT_U_AQAOCNT_U_DT
+34 ;
+35 ;install review criteria for ind
+36 ;no crit for ind
IF '$DATA(^AQAOXX(6,"C",AQAOX))
QUIT
+37 ;install crit & ind links
DO CRIT
End DoDot:1
+38 ;
+39 LOCK -^AQAO(2,0)
NEXT ; go to next rtn for more
+1 DO ^AQAOPOS2
QUIT
+2 ;
+3 ;
CRIT ; SUBRTN to install criteria for ind
+1 LOCK +^AQAO1(6,0):1
IF '$TEST
WRITE !!,"QI REVIEW CRITERIA file locked!"
QUIT
+2 LOCK +^AQAO1(4,0):1
IF '$TEST
WRITE !!,"QI CRITERIA CODES file locked"
QUIT
+3 ;
+4 ;get all crit for ind,add to site's file
SET AQAOC=0
+5 FOR
SET AQAOC=$ORDER(^AQAOXX(6,"C",AQAOX,AQAOC))
IF AQAOC=""
QUIT
Begin DoDot:1
+6 IF '$DATA(^AQAOXX(6,AQAOC,0))
QUIT
SET AQAOS=^(0)
+7 ;
+8 ; if crit doesn't exist, add it
+9 IF '$DATA(^AQAO1(6,"B",$EXTRACT($PIECE(AQAOS,U),1,30)))
Begin DoDot:2
+10 KILL DD,DO,DIC
SET DIC="^AQAO1(6,"
SET DIC(0)="L"
SET X=$PIECE(AQAOS,U)
+11 SET DIC("DR")=".02////"_$PIECE(AQAOS,U,2)_";.03////"_$PIECE(AQAOS,U,3)_";.04////"_$PIECE(AQAOS,U,4)
+12 SET DLAYGO=9002169
DO FILE^DICN
KILL DLAYGO
+13 IF Y=-1
WRITE !!,"Can't ADD ",$PIECE(^AQAOXX(6,AQAOC,0),U)," as criterion."
QUIT
+14 SET AQAOCIFN=+Y
+15 ;
+16 ;add any crit codes, if any
SET AQAOCD=0
+17 FOR
SET AQAOCD=$ORDER(^AQAOXX(6,AQAOC,"CD",AQAOCD))
IF AQAOCD'=+AQAOCD
QUIT
Begin DoDot:3
+18 IF '$DATA(^AQAOXX(6,AQAOC,"CD",AQAOCD,0))
QUIT
SET AQAOCOD=^(0)
+19 SET AQAOSS=$GET(^AQAOXX(4,AQAOCOD,0))
+20 ;get code,create if needed
SET AQAOCODN=$$CODE
IF AQAOCODN=U
QUIT
+21 IF '$DATA(^AQAO1(6,AQAOCIFN,"CD",0))
SET ^(0)="^9002169.61P^^"
+22 SET DIC="^AQAO1(6,"_AQAOCIFN_",""CD"","
SET DA(1)=AQAOCIFN
+23 SET DIC(0)="L"
SET X=AQAOCODN
DO ^DIC
End DoDot:3
End DoDot:2
+24 ;
+25 ; link indicator to crit entry
+26 SET AQAOCIFN=$ORDER(^AQAO1(6,"B",$EXTRACT($PIECE(AQAOS,U),1,30),0))
IF AQAOCIFN=""
QUIT
+27 ;already linked
IF $DATA(^AQAO1(6,"C",AQAOIFN,AQAOCIFN))
QUIT
+28 IF '$DATA(^AQAO1(6,AQAOCIFN,"IND",0))
SET ^(0)="^9002169.699P^^"
+29 SET DIC="^AQAO1(6,"_AQAOCIFN_",""IND"","
SET DA(1)=AQAOCIFN
+30 SET DIC(0)="L"
SET X=$PIECE(^AQAO(2,AQAOIFN,0),U)
DO FILE^DICN
End DoDot:1
+31 LOCK -^AQAO1(6,0)
LOCK -^AQAO1(4,0)
+32 QUIT
+33 ;
+34 ;
CODE() ; EXTR VAR to add crit codes to file
+1 NEW X,DD,DO,DIC,Y,DLAYGO
+2 SET X=$ORDER(^AQAO1(4,"B",$EXTRACT($PIECE(AQAOSS,U),1,30),0))
IF X=""
SET Y=""
+3 IF X]""
IF ($PIECE(AQAOSS,U,2)'=$PIECE(^AQAO1(4,X,0),U,2))
SET Y=""
+4 IF $DATA(Y)
Begin DoDot:1
+5 SET DIC="^AQAO1(4,"
SET DIC(0)="L"
SET DLAYGO=9002169
+6 SET X=$PIECE(AQAOSS,U)
SET DIC("DR")=".02////"_$PIECE(AQAOSS,U,2)
+7 KILL DD,DO
DO FILE^DICN
IF Y=-1
SET X=U
End DoDot:1
+8 QUIT X
+9 ;
+10 ;
INACT() ;EXTR VAR to ask if updating ind is allowed
+1 NEW Y,DIR
+2 SET DIR(0)="SB^N:NONE;S:SELECTED;A:ALL"
+3 SET DIR("A",1)="You already have indicators in your file. If I find"
+4 SET DIR("A",2)="any that match those I sent with this package, I will"
+5 SET DIR("A",3)="UPDATE them if they have been inactivated. You can"
+6 SET DIR("A",4)="choose from: NONE - do not update any"
+7 SET DIR("A",5)=" SELECTED - I will ask about each one"
+8 SET DIR("A",6)=" ALL - update all without further discussion"
+9 SET DIR("A")="UPDATE INACTIVE INDICATORS?"
DO ^DIR
+10 QUIT Y
+11 ;
+12 ;
UPD() ;EXTR VAR to ask if user wants indicator updated
+1 NEW X,Y,DIR
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
+3 SET DIR("A",1)="You already have "_AQAOID_" as an inactive indicator."
+4 SET DIR("A")="Do you want to update this indicator"
DO ^DIR
+5 SET X=$SELECT(Y=1:1,1:U)
+6 QUIT X
+7 ;
+8 ;
DRSET() ;EXTR VAR to set dr string
+1 NEW X,Y
SET DR=""
+2 ;zero node data
SET X=^AQAOXX(2,AQAOX,0)
+3 FOR J=1:1
SET Y=$PIECE($TEXT(DATA2+J),";;",2)
IF Y=""
QUIT
Begin DoDot:1
+4 SET Z=$PIECE($TEXT(DATA2+J),";;",3)
+5 SET DR=DR_";"_Y_"////"_$PIECE(X,U,Z)
End DoDot:1
+6 ;one node data
SET X=^AQAOXX(2,AQAOX,1)
+7 FOR J=1:1
SET Y=$PIECE($TEXT(DATA2A+J),";;",2)
IF Y=""
QUIT
Begin DoDot:1
+8 SET Z=$PIECE($TEXT(DATA2A+J),";;",3)
+9 SET DR=DR_";"_Y_"////"_$PIECE(X,U,Z)
End DoDot:1
+10 SET DR=$EXTRACT(DR,2,250)_";.06////I"
+11 QUIT DR
+12 ;
+13 ;
DATA2 ;; data for step 2 drset extr var
+1 ;;.02;;2
+2 ;;.03;;3
+3 ;;.04;;4
+4 ;;.05;;5
+5 ;
DATA2A ;; data for step 2 drset extr var second loop
+1 ;;.11;;1
+2 ;;.12;;2
