8:07 AM  22-MAR-95
QAI PATCHES 1-2
AQAOCHK0
AQAOCHK0 ; IHS/ORDC/LJF - CHECK OCC NEEDNG REVIEW SUBRTNS ; [ 03/09/95  1:36 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn contains subrtns called by ^AQAOCHK.  These subrtns set
 ;the appropriate array entries based on occurrence status.  These
 ;arrays are used in the printing of the introductory message.
 ;
REFSET ;ENTRY POINT >> set referral data
 S X=$S($P(AQAOREF,";",2)="AQAO(9,":2,1:3)
REFSET1 ;ENTRY POINT >> SUBRTN REFSET but X already set
 I $D(AQAOXYZ)#2 D QIREF ;set all referrals in qi staff
 I X=2 Q:$P(AQAOREF,";")'=AQAODUZ  ;referred to another user
 I X=3 Q:'$D(AQAOXYZ(1,$P(AQAOREF,";")))  ;referred to other team
 D SET1 Q
 ;
 ;
SET ;ENTRY POINT >> SUBRTN to set array variables
 I '($D(AQAOXYZ)#2) Q:'$D(AQAOXYZ(2,AQAOIND))
SET1 I (X=1)!(X=4) Q:'$$SRV  ;check affil srv for auto occ
 S AQAOXYZ(3,X)=$G(AQAOXYZ(3,X))+1 ;increment count
 I X=1 S AQAOSTR=AQAOIND_U_U_U_$$DATESTMP ;initial review data
 I (X=2)!(X=3) S AQAOSTR=AQAOIND_U_$S(AQAOLST=0:$P(^AQAOC(+AQAOIFN,1),U,4),1:$P(^AQAOC(+AQAOIFN,"REV",AQAOLST,0),U,2))_U_AQAOREF_U_$$DATESTMP ;if referral, store indicator & referred by & date review entered
 I X=4 S AQAOSTR=AQAOIND_U_$S(AQAOLST=0:$P(^AQAOC(+AQAOIFN,1),U,3)_U_$P(^(1),U,6),1:$P(^AQAOC(+AQAOIFN,"REV",AQAOLST,0),U)_U_$P(^(0),U,7)) ;for occ not closed,store indicator & review stage
 S ^TMP("AQAOCHK",$J,X,AQAOIND,AQAODT,AQAOIFN)=AQAOSTR ;set occ 4 rprt
 Q
 ;
 ;
QIREF ; >> SUBRTN to set all referrals in user is qi staff
 S AQAOXYZ(3,X,1)=$G(AQAOXYZ(3,X,1))+1 ;increment count
 I $D(AQAOXYZ(1,$P(AQAOREF,";"))) S AQAOXYZ(3,X)=$G(AQAOXYZ(3,X))+1
 S AQAOSTR=AQAOIND_U_$S(AQAOLST=0:$P(^AQAOC(+AQAOIFN,1),U,4),1:$P(^AQAOC(+AQAOIFN,"REV",AQAOLST,0),U,2)) ;if referral, store indicator & referred by
 S AQAOSTR=AQAOSTR_U_AQAOREF_U_$$DATESTMP ;include referred to
 S ^TMP("AQAOCHK",$J,X,AQAOIND,AQAODT,AQAOIFN,1)=AQAOSTR ;set occ 4 rprt
 Q
 ;
 ;
DATESTMP()         ;EXTRN VAR to find data occ or review entered
 ;used to see if occ overdue for review
 N AQAODT,AQAOU S AQAOU=0 Q:X>3
 F  S AQAOU=$O(^AQAGU("AC",+AQAOIFN,AQAOU)) Q:AQAOU=""  Q:$D(AQAODT)  D
 .I X=1 Q:$P($G(^AQAGU(AQAOU,0)),U,4)'="O"
 .I X>1 Q:$P($G(^AQAGU(AQAOU,0)),U,4)'="E"
 .I X>1,AQAOLST=0 Q:$P($G(^AQAGU(AQAOU,0)),U,5)'="INITIAL REVIEW"
 .I X>1,AQAOLST>0 Q:$P($G(^AQAGU(AQAOU,0)),U,6)'=AQAOLST
 .S AQAODT=$P($G(^AQAGU(AQAOU,0)),U) ;date/time stamp
 Q $G(AQAODT)
 ;
 ;
OVERDUE() ;ENTRY POINT for EXTRN VAR
 ;to print * if occ overdue for review
 ;called by AQAOCHK2
 N AQAOP,X
 S X1=DT,X2=$P(AQAOSTR,U,4) D ^%DTC
 I X>$P(^AQAGP(DUZ(2),0),U,2) S AQAOP="*"
 Q $G(AQAOP)
 ;
 ;
SRV() ;EXTRN VAR to see if service screen is needed
 N X,Y S Y=1,X=0
 I $P(^AQAOC(AQAOIFN,0),U,11)=1,$P(^(0),U,7)]"",'($D(AQAOXYZ)#2) D
 .F  S X=$O(AQAOXYZ(1,X)) Q:X=""  I $D(^AQAO(2,"AC",X,$P(^AQAOC(AQAOIFN,0),U,8))),$D(^AQAO1(1,"AB",$P(^AQAOC(AQAOIFN,0),U,7),X)) Q  ;PATCH 2
 I X="" S Y=0 ;is auto occ and user not have access to team/srv combo
 Q Y

AQAOCID
AQAOCID ; IHS/ORDC/LJF - CREATE COMPUTED NUMBERS 4 FILES ; [ 12/21/94  6:28 AM ]
 ;;1;QAI MANAGEMENT;**1**;AUG 15, 1994
 ;
 ;This rtn is a PRIVATE ENTRY POINT for computing the case ID
 ;number for an occurrence.  The entry is called using $$OCCID^AQAOCID.
 ;
OCCID() ;PEP;PRIVATE ENTRY POINT for EXTR VAR to create occurrence id number
 ;private published entry point: can only be called by AQAL pkg
 ;REQUIRED INPUT:   AQAOPAT=PATIENT DFN
 ;                  AQAODATE=OCCURRENCE DATE
 ;                  AQAOIND=INDICATOR
 ;
MONTH ; (1) MONTH OF OCCURRENCE (ALPHA A THROUGH L)
 S AQAOCID=$C($E(AQAODATE,4,5)+64)
 ;
DAY ; (2) DAY OF OCCURRENCE (ALPHA A THROUGH Z, 27=1,28=2,29=3,30=4,31=5) 
 S AQAODAY=$E(AQAODATE,6,7)
 S AQAOCID=AQAOCID_$S(AQAODAY>26:AQAODAY-26,1:$C(AQAODAY+64))
 ;
LNAME ; (3) LAST NAME (FIRST LETTER OF LAST NAME)
 S AQAONAM=$P($G(^DPT(AQAOPAT,0)),U) S:AQAONAM="" AQAONAM="Z"
 S AQAOCID=AQAOCID_$E(AQAONAM)
 ;
FUDGE ; (4-7) RANDOM 3-DIGIT NUMBER; THEN CHECK IF UNIQUE
 S X=AQAOCID_$R(9999) I $D(^AQAOC("B",X)) G FUDGE ;PATCH 1 w/ next line
 Q X
 ;
 ;
NEWAP() ;ENTRY POINT for EXTR VAR to create action plan number
 ;
 N %H,Y,X
 ;first get facility's abbreviation
 S AQAOAPN=$P($G(^AUTTLOC(DUZ(2),0)),U,2)_"QI",AQAOAPN=$E(AQAOAPN,1,4)
 S %H=$H D YMD^%DTC S Y=$E(X,2,3) I $E(X,4,5)>9 S Y=Y+1 ;fiscal year
 S (X,Y,AQAOAPN)=AQAOAPN_Y_"1000"
 F  S X=$O(^AQAO(5,"B",X)) Q:X=""  Q:($E(X,5,6)>$E(AQAOAPN,5,6))  S Y=X
 S AQAOAPN=$E(AQAOAPN,1,6)_($E(Y,7,10)+1)
 I $L(AQAOAPN)'=10 S AQAOAPN=""
 Q AQAOAPN

AQAOENTS
AQAOENTS ; IHS/ORDC/LJF - CREATE OCC FROM SEARCH TEMPL ; [ 03/09/95  3:56 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn is called by ^AQAOENTR if the user chose to create occ
 ;from a visit-based search template.  The user is asked for the
 ;template name and indicator.  Then it loops through all entries in
 ;the template, asking for occ date for each one as it creates 
 ;occurrences.  The case ID name is displayed for each.
 ;
 W !!!,"CREATE OCCURRENCES FROM A VISIT SEARCH TEMPLATE",!!
TEMP ; >>> ask user for search template name
 K DIC S DIC="^DIBT(",DIC(0)="AEMQZ"
 S DIC("S")="I $P(^DIBT(Y,0),U,4)=9000010,$D(^DIBT(Y,1))" ;visit scrn
 S DIC("?")="Must be a search template created on the Visit file!"
 D ^DIC G EXIT:$D(DTOUT),EXIT:$D(DUOUT),EXIT:X="",TEMP:Y=-1
 S AQAOTMP=+Y ;search template ifn
 ;
IND ; >>> ask user to select indicator
 S Y=$$IND^AQAOLKP ;ask user to select an indicator for all visits
 S AQAOIN=$S(Y>0:+Y,1:"")
 I AQAOIN="" D  I Y'=1 G IND
 .W !!,"You have not selected an indicator"
 .W !,"This means you must enter the indicator for each template entry."
 .K DIR S DIR(0)="Y",DIR("B")="NO"
 .S DIR("A")="Do you wish to continue" D ^DIR
 ;
 W !!,"I will take all entries from the search template "
 W $P(^DIBT(AQAOTMP,0),U)
 W !,"and create occurrences for indicator "
 W $S(AQAOIN="":"you select as each is entered.",1:$P(^AQAO(2,AQAOIN,0),U))
 K DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="Is this correct" D ^DIR
 I Y'=1 G TEMP
 ;
LOOP ; >>> loop thru template entries and create occ
 S AQAOV=0,AQAOSTOP=""
 F  S AQAOV=$O(^DIBT(AQAOTMP,1,AQAOV)) Q:AQAOV=""  Q:AQAOSTOP=U  D
 .W !! S L=0,DIC="^AUPNVSIT(",FLDS="[AQAO VISIT DATA]",BY="@NUMBER"
 .S (TO,FR)=AQAOV,DHD="@@",IOP="HOME" D EN1^DIP
 .S X=$P(^AUPNVSIT(AQAOV,0),U),X=$$FMTE^XLFDT($P(X,"."),1) ;PATCH 2
 .S AQAODATE=$$OCCDT^AQAOLKP(X) Q:AQAODATE=""  ;ask for occ dt;PATCH 2
 .I $D(DIRUT)!(X=U) S AQAOSTOP=U Q
 .S AQAOIND=$S(AQAOIN="":$$IND^AQAOLKP,1:AQAOIN) Q:AQAOIND=""  ;ask ind
 .I $D(DIRUT)!(X=U) S AQAOSTOP=U Q
 .S AQAOPAT=$P(^AUPNVSIT(AQAOV,0),U,5) Q:AQAOPAT=""  ;pat dfn
 .D ^AQAOENTQ
 .I $D(DIRUT)!(X=U) S AQAOSTOP=U Q
 .I $D(AQAO) W !!,"Okay, I won't add another occurrence for this visit" Q
 .K AQAOIFN D CREATE^AQAOLKP Q:'$D(AQAOIFN)  ;create occ
 .S DIE="^AQAOC(",DA=AQAOIFN,DR=".03////"_AQAOV D ^DIE ;stuff visit
 .K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
 .I Y=0 S AQAOSTOP=U
 ;
 ;
EXIT ; >>> eoj
 D KILL^AQAOUTIL Q

AQAOLKP
AQAOLKP ; IHS/ORDC/LJF - LOOKUP UTILITIES ; [ 03/09/95  3:04 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn contains entry points for occurrence selection, adding an
 ;occurrence and extrinsic variables for asking user to select occ
 ;date, indicator, beginning date, and ending date.  Also includes
 ;extrinsic variable for a screen on review type.
 ;
ASK ;ENTRY POINT for selecting occurrence
 ; >>> ask for occ id or patient name or indicator
 K AQAOIFN W !! K DIC S DIC="^AQAOC(",DIC(0)="AEMQZ"
 S DIC("A")="Select OCCURRENCE (ID #, Patient, or Indicator):  "
 S DIC("S")="D OCCCHK^AQAOSEC I $D(AQAOCHK(""OK""))"
 D ^DIC Q:$D(DTOUT)  Q:$D(DUOUT)  Q:X=""  Q:Y=-1
 S AQAOIFN=+Y,AQAOCID=Y(0,0)
 S AQAOPAT=$P(Y(0),U,2),AQAOIND=$P(Y(0),U,8),AQAODATE=$P(Y(0),U,4)
 ;
 ; >> display occurrence
 S L="",DIC="^AQAOC(",FLDS="[AQAO OCC SHORT DISPLAY]"
 S BY="@NUMBER",(TO,FR)=AQAOIFN,IOP=IO(0) D EN1^DIP ;display occurrence
 K DIR S DIR(0)="E"
 S DIR("A")="Press RETURN to continue OR '^' to select another occurrence"
 D ^DIR
 Q
 ;
 ;
ADD ;ENTRY POINT for adding new occurrence
 ; >>> ask patient name & date & indicator then enter
 W ! K DIC S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC Q:Y=-1  S AQAOPAT=+Y
 ;
 W ! S %DT="AETX",%DT("A")="Enter OCCURRENCE DATE: " D ^%DT
 G:Y=-1 ADD S AQAODATE=+Y
 ;
 W ! K DIC S DIC="^AQAO(2,",DIC(0)="AEMQ" ;indicator lookup
 S DIC("S")="D INDCHK^AQAOSEC I $D(AQAOCHK(""OK"")),+$G(^AQAO(2,Y,1))"
 S DIC("A")="Enter CLINICAL INDICATOR:  "
 D ^DIC K AQAOCHK("OK") W ! G:Y=-1 ADD S AQAOIND=+Y
 ;
 ;
CHECK ; >>> check if occurrence already entered; if so go to edit
 D ^AQAOENTQ I $D(DIRUT) K DIRUT G ADD
 I $D(AQAO) S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="E",AQAOUDIT("COMMENT")="EDIT OCCURRENCE" D ^AQAOAUD Q
 D CREATE G ASK:'$D(AQAOCID)
 Q
 ;
 ;
CREATE ;ENTRY POINT else, create case identifier than add entry
 W !!,"Please wait while I create the occurrence entry . . ."
 S AQAOCID=$$OCCID^AQAOCID Q:AQAOCID=""
 S DIC="^AQAOC(",DIC(0)="AEMQ"
 S DIC("DR")=".02////"_AQAOPAT_";.04////"_AQAODATE_";.08////"_AQAOIND_";.09////"_DUZ(2)_";.11///^S X=0"
 L +^AQAGU(0):1 I '$T W !!,"CANNOT ADD; AUDIT FILE LOCKED. TRY AGAIN.",! Q
 L +(^AQAOC(0)):1 I '$T W !,"CANNOT ADD NEW ENTRY; ANOTHER USER ADDING TO FILE. TRY AGAIN." Q
 S X=AQAOCID K DD,DO,DINUM D FILE^DICN K DIC("DR")
 L -(^AQAOC(0)):0 I Y=-1 L -^AQAGU(0) Q
 S AQAOIFN=+Y ;ifn in qi occurrence file
 W !!,"Your CASE # is ",AQAOCID,!
 ;
AUDIT S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="O"
 S AQAOUDIT("COMMENT")="OPEN A RECORD" D ^AQAOAUD
 Q
 ;
 ;
OCCDT(V) ;ENTRY POINT  EXTR FUNC to ask user for occ date;PATCH 2
 N Y,%DT
 W ! S %DT="AEX",%DT("A")="Enter OCCURRENCE DATE: "
 S %DT("B")=V D ^%DT ;PATCH 2
 Q Y
 ;
 ;
IND() ;ENTRY POINT  EXTR VAR to ask user for indicator
 N DIC,Y
 W !! S DIC="^AQAO(2,",DIC(0)="AEMQZ"
 S DIC("S")="D INDCHK^AQAOSEC I $D(AQAOCHK(""OK""))"
 S DIC("A")="Enter CLINICAL INDICATOR:  " D ^DIC K AQAOCHK("OK")
 I $D(DTOUT)!($D(DUOUT))!(X="") S Y=U
 Q Y
 ;
 ;
BDATE() ;ENTRY POINT  EXTR VAR ask user to choose beginning date for report
BD1 N DIR,Y
 W !! S DIR(0)="DO^::EX",DIR("A")="Select EARLIEST OCCURRENCE DATE"
 D ^DIR I Y>DT W *7,"   NO FUTURE DATES" G BD1
 S Y=$S(Y>0:Y,$D(DTOUT):U,1:"")
 Q Y
 ;
EDATE() ;ENTRY POINT  EXTR VAR ask user to choose ending date for report
ED1 N DIR,Y
 W ! S DIR(0)="DO^::EX",DIR("A")="Select LATEST OCCURRENCE DATE"
 D ^DIR I Y>DT W *7,"   NO FUTURE DATES" G ED1
 I +Y,(Y<AQAOBD) W *7," ENDING DATE MUST BE AFTER BEGINNING DATE" S Y=""
 S Y=$S(Y>0:Y,$D(DTOUT):U,1:"")
 Q Y
 ;
 ;
RTYPE() ;EP; EXTRN VAR - screen on selecting review types 
 ; to select BTR must have Blood Product file
 ; to select PTF must have Drug file
 N X S X=0
 I (Y<3)!(Y>5) S X=1 G RTEND ;not type that needs screen
 I (Y=3),$O(^LAB(66,0)) S X=1 G RTEND ;check for blood product file
 I $O(^PSDRUG(0)),$D(^DD(50.6,0))#2 S X=1 ;check for drug file
RTEND Q X
 ;
EXCEP(X) ;EP; EXTRN FUNC to test whether ind has exception recorded
 Q $S($P($G(^AQAOC(X,1)),U,2)]"":1,1:0)

AQAOPC51
AQAOPC51 ; IHS/ORDC/LJF - CALC FOR QTR PROGRESS RPT ; [ 03/09/95  3:55 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn counts occ finding/action pairs by month for indicator(s)
 ;selected by user.  It also finds action plans tied to the indicators.
 ;
 K ^TMP("AQAOPC5A",$J),^TMP("AQAOPC5B",$J) ;start with clean globals
 ;
TMP ; >>> loop thru ^TMP to find indicators
 F AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","OTHER" D  ;PATCH 2
 .S AQAOF=AQAOI
 .F  S AQAOF=$O(^TMP("AQAOPC5",$J,1,AQAOF)) Q:AQAOF'[AQAOI  D
 ..S AQAOIND=0
 ..F  S AQAOIND=$O(^TMP("AQAOPC5",$J,1,AQAOF,AQAOIND)) Q:AQAOIND=""  D
 ...;
 ...; >>for this indicator, find occ for date range
 ...S AQAODT=AQAOBD-.001
 ...F  S AQAODT=$O(^AQAOC("AA",AQAOIND,AQAODT)) Q:AQAODT=""  Q:AQAODT>(AQAOED_".24")  D
 ....S DFN=0
 ....F  S DFN=$O(^AQAOC("AA",AQAOIND,AQAODT,DFN)) Q:DFN=""  D
 .....S AQAOIFN=0
 .....F  S AQAOIFN=$O(^AQAOC("AA",AQAOIND,AQAODT,DFN,AQAOIFN)) Q:AQAOIFN=""  D
 ......D CHECK ;check occ for validity
 ......Q:'$D(AQAOK)  ;occ not valid for this report
 ......D COUNT ;increment counts
 ...;
 ...; >>for this indicator, find any action plans linked to it for dates
 ...D ACTION ;check if action plan linked for date range
 ;
PRINT ; >>> go to print rtn
 I $D(AQAODLM) G ^AQAOPC53 ; ASCIIformat
 G ^AQAOPC52
 ;
 ;
 ;
CHECK ; >> SUBRTN to check out occurrence
 K AQAOK ;occ okay flag
 I '$D(^AQAOC(AQAOIFN,0)) Q  ;bad xref
 Q:'$D(^AQAOC(AQAOIFN,1))  Q:$P(^(1),U)'=1  ;not closed
 Q:$$EXCEP^AQAOLKP(AQAOIFN)  ;exception to criteria
 Q:'$D(^AQAOC(AQAOIFN,"FINAL"))  S AQAOS=^("FINAL")
 ;Q:$P(AQAOS,U,4)=""  Q:$P(AQAOS,U,6)=""  ;need final finding & action
 S AQAOK="" Q
 ;
 ;
COUNT ; >> SUBRTN to increment counts of findings, actions by indicator
 ;
 S X=$P(AQAOS,U,4),AQAOFA=$S(X="":"??",1:$P(^AQAO(8,X,0),U,2)) ;findng
 S X=$P(AQAOS,U,6),AQAOAA=$S(X="":"??",1:$P(^AQAO(6,X,0),U,2)) ;action
 S AQAOMON=$E(AQAODT,1,5) ;month of occ
 ;
 ;increment total count for indicator
 S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND))+1
 ;increment count for ind for find&action
 S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA))+1
 ;increment for find&act&month
 S ^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON)=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAA,AQAOMON))+1
 Q
 ;
 ;
ACTION ; >> SUBRTN to find any action plans tied to ind for date range
 S AQAOAC=0
 F  S AQAOAC=$O(^AQAO(5,"C",AQAOIND,AQAOAC)) Q:AQAOAC=""  D
 .Q:'$D(^AQAO(5,AQAOAC,0))  S AQAOS=^(0)
 .Q:$P(AQAOS,U,5)=9  ;deleted action plan
 .Q:$P(AQAOS,U,3)<AQAOBD  ;implemented before those occurrences
 .S ^TMP("AQAOPC5B",$J,AQAOIND,AQAOAC)=""
 Q

AQAOPC52
AQAOPC52 ; IHS/ORDC/LJF - PRINT QTR PROGRESS RPRT ; [ 03/10/95  2:22 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn prints occ finding/action counts by month in a matrix,
 ;months along the top and finding/action pairs down the side.
 ;Totals by month and totals by finding/action pair are also printed.
 ;Any action plans associated with the indicator are printed at the 
 ;bottom of each indicator page.
 ;
INIT ; >> initialize variables
 D MONTHS ;set array for all months included in report
 ;use wide margin if date range has more than 7 months
 S AQAOIOMX=80
 I Y>7 S AQAOIOM=IOM,(AQAOIOMX,X)=132 X:IOT'="HFS" ^%ZOSF("RM")
 S AQAOLIN3="",$P(AQAOLIN3,"-",AQAOIOMX-10)=""
 D INIT^AQAOUTIL S AQAOHCON="Patient"
 S AQAOTY=$S($D(AQAORPTT):AQAORPTT,1:"PROGRESS REPORT")
 S Y=AQAOBD X ^DD("DD") S AQAORNG="("_Y,Y=AQAOED-31 X ^DD("DD")
 S AQAORNG=AQAORNG_" - "_Y_")" ;date range
 ;
LOOP ; >> loop thru ^tmp to get data then print it
 S AQAOF=0
 F  S AQAOF=$O(^TMP("AQAOPC5",$J,1,AQAOF)) Q:AQAOF=""  Q:AQAOSTOP=U  D
 .S:AQAOTYP=1 AQAOIND=$O(^TMP("AQAOPC5",$J,1,AQAOF,0)),AQAOM=$$INDNAME
 .I AQAOPAGE=0 D HEADING^AQAOUTIL,HDG2 I 1
 .E  D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2
 .S AQAOIND=0
 .F  S AQAOIND=$O(^TMP("AQAOPC5",$J,1,AQAOF,AQAOIND)) Q:AQAOIND=""  Q:AQAOSTOP=U  D
 ..I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2
 ..S AQAOM=$$INDNAME ;set indicator heading
 ..I AQAOTYP>1 W !!,AQAOM,!
 ..S AQAOIT=$G(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND))
 ..I AQAOIT=0 W !?10,">> NO OCCURRENCES FOUND FOR THIS INDICATOR <<" Q
 ..E  D COUNTP ;print counts by month
 ..D ACTION^AQAOPC54 ;include action plans
 ;
 ;
EXIT ; >>> eoj        
 I IOST["C-" D PRTOPT^AQAOVAR
 I $D(AQAOIOM),IOT'="HFS" S X=AQAOIOM X ^%ZOSF("RM")
 D ^%ZISC D KILL^AQAOUTIL
 K ^TMP("AQAOPC5",$J),^TMP("AQAOPC5A",$J),^TMP("AQAOPC5B",$J)
 Q
 ;
 ;
 ;
COUNTP ; >> SUBRTN to print line for all find/act combos with counts by month
 D MONTHS ;PATCH 2
 S AQAOFA=0 ;get next finding
 F  S AQAOFA=$O(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA)) Q:AQAOFA=""  Q:AQAOSTOP=U  D
 .S AQAOAC=0 ;get next action for this finding
 .F  S AQAOAC=$O(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAC)) Q:AQAOAC=""  Q:AQAOSTOP=U  D
 ..S AQAOFAT=^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAC) ;f/a subtl
 ..I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2
 ..W !,AQAOFA,"/",AQAOAC,?8
 ..;
 ..;fill in counts for all months
 ..S AQAOMON=0
 ..F  S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON=""  Q:AQAOSTOP=U  D
 ...I '$D(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAC,AQAOMON)) D  Q
 ....S X=$X+9 W ?X
 ...S X=^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAC,AQAOMON)
 ...W ?($X+1),$J(X,8) ; print count for month
 ...S AQAOARM(AQAOMON)=AQAOARM(AQAOMON)+X ;increment total
 ..W ?AQAOIOMX-11,$J(AQAOFAT,8)
 ..;
 ..;fill in percentages for all months for this find/act combo
 ..I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2
 ..W !?8 S AQAOMON=0
 ..F  S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON=""  Q:AQAOSTOP=U  D
 ...I '$D(^TMP("AQAOPC5A",$J,AQAOF,AQAOIND,AQAOFA,AQAOAC,AQAOMON)) D  Q
 ....S X=$X+9 W ?X
 ..W ?AQAOIOMX-12,$J(AQAOFAT/AQAOIT*100,8,2),"%" ;find/act as % total
 ;
 ;
 ;print monthly totals for this indicator
 I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U  D HDG2
 W !?9,AQAOLIN3,!,"Monthly:" S AQAOMON=0
 F  S AQAOMON=$O(AQAOARM(AQAOMON))  Q:AQAOMON=""  Q:AQAOSTOP=U  D
 .W ?($X+1),$J(AQAOARM(AQAOMON),8) ;# of occ by month
 W ?AQAOIOMX-11,$J(+AQAOIT,8)
 ;                                 ;print % for each month for ind
 S AQAOMON=0 W !?8
 F  S AQAOMON=$O(AQAOARM(AQAOMON))  Q:AQAOMON=""  Q:AQAOSTOP=U  D
 .W:AQAOIT>0 $J(AQAOARM(AQAOMON)/AQAOIT*100,8,2),"%" ;% of occ
 W !
 Q
 ;
 ;
MONTHS ; >> SUBRTN to create array for months in report&init their counts
 S X=AQAOBD,Y=0 F  Q:X>AQAOED  D
 .I $E(X,4,5)=13 S X=($E(X,1,3)+1)_"0100"
 .S AQAOARM($E(X,1,5))=0
 .S X=X+100,Y=Y+1
 Q
 ;
 ;
HDG2 ; >> SUBRTN to print 2nd half of heading
 W ?AQAOIOMX-$L(AQAORNG)/2,AQAORNG,!
 I AQAOTYP=1 W ?AQAOIOMX-$L(AQAOM)/2,AQAOM
 E  W ?AQAOIOMX-$L(AQAOF)/2,AQAOF
 W !,AQAOLIN2,!,"Find/Act"
 S X=0
 F  S X=$O(AQAOARM(X)) Q:X=""  W ?($X+2),1700+$E(X,1,3),"/",$E(X,4,5)
 W ?AQAOIOMX-9," Totals"
 W !,AQAOLINE
 Q
 ;
 ;
INDNAME()          ;ENTRY POINT EXTR VAR - sets the indicator heading variable
 S AQAOT=^AQAO(2,AQAOIND,0),AQAOM=$P(AQAOT,U)_"-"_$P(AQAOT,U,2)
 S Y=$P(AQAOT,U,3),C=$P(^DD(9002168.2,.03,0),U,2) D Y^DIQ
 S AQAOZ=" ("_Y ;add on process vs. outcome
 S Y=$P(AQAOT,U,4),C=$P(^DD(9002168.2,.04,0),U,2) D Y^DIQ
 S AQAOZ=AQAOZ_"/"_Y ;add on sentinel vs. rate-based
 S Y=$P(AQAOT,U,5) I Y]"" S C=$P(^DD(9002168.2,.05,0),U,2) D Y^DIQ
 S AQAOZ=$S(Y="":AQAOZ_")",1:AQAOZ_"/"_Y_")"),AQAOM=AQAOM_AQAOZ
 S AQAOM="*** "_AQAOM_" ***"
 Q AQAOM

AQAOPU1
AQAOPU1 ; IHS/ORDC/LJF - INDICATOR SELECTION ; [ 03/09/95  3:55 PM ]
 ;;1;QAI MANAGEMENT;**1,2**;AUG 15, 1994
 ;
 ;This rtn contains an extrinsic function called by various reports
 ;to select facility-defined report format.  These formats contain a
 ;defined set of grouped indicators.
 ;
FACR(AQAOSUB) ;ENTRY POINT EXTR FUNC - select facility specific report to run
 K ^TMP(AQAOSUB,$J) ;PATCH 1
 S AQAOTYP=Y ;set report type
 ;
 ; >> user gets choice of facilities if user has access >1 site
 S AQAOFAC=DUZ(2),X=$O(^VA(200,DUZ,2,0)) I X]"" D
 .S X=$O(^VA(200,DUZ,2,X)) I X]"" D
 ..W !! K DIC S DIC="^AQAGP(",DIC(0)="AEMZQ"
 ..S DIC("A")="Select FACILITY first:  " D ^DIC
 ..I Y<1 S AQAOTYP=U
 ..E  S AQAOFAC=+Y
 I AQAOTYP=U Q AQAOTYP
 ;
 ; >> user selects report format
 I '$D(^AQAGP(AQAOFAC,"FACRPT",0)) S ^(0)="^9002166.41"
 W !! K DIC,DA S DIC="^AQAGP("_AQAOFAC_",""FACRPT"",",DIC(0)="AEMZQ"
 S DIC("S")="I '$O(^AQAGP(AQAOFAC,""FACRPT"",Y,""RES"",0))!$D(^AQAGP(AQAOFAC,""FACRPT"",Y,""RES"",""B"",DUZ))" ;PATCH 1
 S DA(1)=AQAOFAC D ^DIC I Y<1 S AQAOTYP=U Q AQAOTYP
 S AQAORPT=Y ;report name & number
 S AQAORPTT=$P(^AQAGP(AQAOFAC,"FACRPT",+AQAORPT,0),U,2) ;report title
 ;
 ; >> find contents of report selected
 F AQAOI="MSF","HW","KF","IND" D
 .S AQAOX=0 ;for each heading, find indicators
 .F  S AQAOX=$O(^AQAGP(AQAOFAC,"FACRPT",+AQAORPT,AQAOI,AQAOX)) Q:AQAOX'=+AQAOX  D
 ..Q:'$D(^AQAGP(AQAOFAC,"FACRPT",+AQAORPT,AQAOI,AQAOX,0))  S AQAOS=+^(0)
 ..I (AQAOI="HW")!(AQAOI="IND") S Y=AQAOS D INDCHK^AQAOPU,SET Q
 ..;
 ..S AQAOC=$S(AQAOI="MSF":"AD",1:"AB") ;xref in qi ind file
 ..S Y=0 F  S Y=$O(^AQAO(2,AQAOC,AQAOS,Y)) Q:Y=""  D INDCHK^AQAOPU,SET
 ;
 ; >> display indicators included in report
 D DISPLAY
 ;
 Q AQAOTYP
 ;
 ;
SET ; >> SUBRTN to set indicator array
 I (AQAOI="MSF")!(AQAOI="KF") Q:$G(AQAOCHK("OK"))="I"  ;inactive ind
 I AQAOI="HW" S AQAOF="FACILITY WIDE INDICATORS" ;PATCH 2
 I AQAOI="IND" S AQAOF="OTHER INDICATORS"
 I AQAOI="KF" S AQAOF="KEY FUNCTION - "_$P(^AQAO(1,AQAOS,0),U)
 I AQAOI="MSF" D
 .S AQAOZ=Y,Y=AQAOS,C=$P(^DD(9002168.2,.13,0),U,2) D Y^DIQ
 .S AQAOF="MED STAFF FUNCTION - "_Y,Y=AQAOZ
 I $D(AQAOCHK("OK")) S ^TMP(AQAOSUB,$J,1,AQAOF,Y)=""
 E  S ^TMP(AQAOSUB,$J,2,$P(^AQAO(2,Y,0),U))=""
 Q
 ;
 ;
DISPLAY ; >> SUBRTN to display indicators found for report
 S X="Facility Specific Report:  "_$P(AQAORPT,U,2) W @IOF,!!,X
 W !!,"Indicators To Be Included In This Report:"
 I '$D(^TMP(AQAOSUB,$J,1)) W !!,"NONE FOUND" S AQAOTYP=U G DSPLY9
 S X=0 F  S X=$O(^TMP(AQAOSUB,$J,1,X)) Q:X=""  Q:$G(AQAOSTOP)=U  D
 .W !!,"HEADING: ",X
 .S Y=0 F  S Y=$O(^TMP(AQAOSUB,$J,1,X,Y)) Q:Y=""  Q:$G(AQAOSTOP)=U  D
 ..W !?9,$P(^AQAO(2,Y,0),U),?20,$P(^(0),U,2)
 ..I $Y>(IOSL-4) S AQAOSTOP=$$EOP^AQAOPU Q:AQAOSTOP=U
 I $D(^TMP(AQAOSUB,$J,2)) D
 .W !!,"Indicators NOT To Be Included: (You do not have access to them)"
 .S X=0 F  S X=$O(^TMP(AQAOSUB,$J,2,X)) Q:X=""  D
 ..W !?5,X
 ..I $Y>(IOSL-4) S AQAOSTOP=$$EOP^AQAOPU Q:AQAOSTOP=U
DSPLY9 W !! K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
 Q

AQAOREV
AQAOREV ; IHS/ORDC/LJF - ENTER OCCURRENCE REVIEWS ; [ 12/02/94  8:32 AM ]
 ;;1;QAI MANAGEMENT;**1**;AUG 15, 1994
 ;
 ;This rtn contains the user interface to enter occurrence reviews.
 ;
ASK ; >> ask for occ id
 I $D(AQAOIFN) L -^AQAOC(AQAOIFN) ;unlock last occ reviewed
 S AQAORVW="" ;flag:allow referred to reviewer to see occ
 D INTRO^AQAOHREV ;intro text
 K AQAOIFN ;start out clean, no occ variable
 ;
 D ASK^AQAOLKP G EXIT:'$D(AQAOIFN),EXIT:$D(DUOUT),EXIT:$D(DTOUT)
 ;
START ; >> lock entry, display summary, display reviews
 L +^AQAOC(AQAOIFN):1 I '$T D  G ASK
 .W !!,"CANNOT EDIT; ANOTHER USER IS EDITING THIS OCCURRENCE.",!
 ;
 W !! K DIR S DIR(0)="Y",DIR("B")="NO"
 S DIR("A")="Do you wish to see this occurrence's SUMMARY" D ^DIR
 I Y=1 S X=AQAOIFN D SUM^AQAOREV1
 ;
 D FIND^AQAOREV1 G ASK:AQAOSTOP=U ;find and display all reviews
 ;
CHOOSE ; >> choose review entry to add or edit
 I AQAONUM=0 D ADD G:'$D(AQAORIFN) ASK G EDIT ;if none, try add
 K DIR S DIR(0)="NO^1:"_(AQAONUM+1),DIR("A")="Choose ONE from list"
 S DIR("A",1)=(AQAONUM+1)_".  ADD a NEW REVIEW Entry"
 D ^DIR G EXIT:$D(DIRUT)
 I Y=(AQAONUM+1) D  G:'$D(AQAORIFN) ASK I 1 ;chose to add new entry
 .K AQAO,AQAORIFN D ADD
 E  S AQAORIFN=$P(AQAO(+Y),U) ;chose to edit an entry
 ;
EDIT ; edit review
 L +^AQAGU(0):1 I '$T D  G EXIT
 .W !!,"CANNOT ENTER REVIEW; AUDIT FILE LOCKED. TRY AGAIN.",!
 S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="E"
 S AQAOUDIT("REV")=AQAORIFN
 S AQAOUDIT("COMMENT")="EDIT OCCURRENCE REVIEW" D ^AQAOAUD
 ;
 K DIE,DIR S DIE="^AQAOC("_AQAOIFN_",""REV"",",DA(1)=AQAOIFN,DA=AQAORIFN
 S DR=".01;S AQAORLX=X;.02;.04;I AQAORLX=1 S Y=""@1"";.011;.06;@1;.05;.07;S:$P(^AQAO(6,$P(^AQAOC(AQAOIFN,""REV"",AQAORIFN,0),U,7),0),U,4)'=1 Y=""@2"";.09;2;@2;1"
 D ^DIE
 ;
 S AQAOACT=$P($G(^AQAOC(AQAOIFN,"REV",AQAORIFN,0)),U,7) ;action;PATCH 1
 I AQAOACT]"",$P(^AQAO(6,AQAOACT,0),U,4)=2 D  ;practitioner action
 .S AQAOPT=$O(^AQAQX("B","AQAO PROV ACTION",0)) Q:AQAOPT=""
 .K AQAOP D ^AQAOEDTS ;call data entry driver
 ;E  I +^AQAOC(AQAOIFN,"REV",AQAORIFN,0)>2 D  ;peer/committee only
 ;.S AQAOPT=$O(^AQAQX("B","AQAO PROV LEVEL",0)) Q:AQAOPT=""
 ;.K AQAOP D ^AQAOEDTS
 ;
 I $D(^XUSEC("AQAOZVAL",DUZ)),$P($G(^AQAO(6,+AQAOACT,0)),U,4)'=1,'$O(^AQAOC(AQAOIFN,"REV",AQAORIFN)) D
 .S AQAOENTR="" D CLOSE^AQAOVAL K AQAOENTR ;close out occ
 ;
 D PRTOPT^AQAOVAR G ASK
 ;
EXIT ; >> eoj
 I $D(AQAOIFN) L -^AQAOC(AQAOIFN)
 D KILL^AQAOUTIL Q
 ;
ADD ; SUBRTN to add new review to occ
 L +^AQAGU(0):1 I '$T D  Q
 .W !!,"CANNOT ADD NEW REVIEW; AUDIT FILE LOCKED.  TRY AGAIN.",!
 W !!,"(To add a review for a stage already used, enter in quotes, i.e. ""PEER"".)"
 I '$D(^AQAOC(AQAOIFN,"REV",0)) S ^AQAOC(AQAOIFN,"REV",0)="^9002167.01P^^"
 K DIC S DIC="^AQAOC("_AQAOIFN_",""REV"",",DA(1)=AQAOIFN
 S DIC(0)="AEMZQL" D ^DIC I +Y>0 S AQAORIFN=+Y
 Q:'$D(AQAORIFN)  S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="E"
 S AQAOUDIT("COMMENT")="ADD OCCURRENCE REVIEW",AQAOUDIT("REV")=AQAORIFN
 D ^AQAOAUD
 Q

AQAOUHLP
AQAOUHLP ; IHS/ORDC/LJF - HELP OPTION ON MAIN MENU ; [ 03/13/95  12:04 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn is the help option from the mian menu.  It contains an
 ;introduction to the package, a list of manuals available, a list
 ;of a facility's package administrator, and a user's access level.
 ;In future version it will contain a list of enhancements.
 ;
 W @IOF,!!?20,"HELP IN USING QAI MGT SYSTEM",!
 ;
MENU ; >>> create 4 option menu of help
 W !!! K DIR S DIR("A")="Select HELP Option"
 S DIR(0)="SO^1:ON-LINE HELP;2:PATCHES & ENHANCEMENTS;3:MANUALS AVAILABLE;4:WHO IS THE PKG ADMINISTRATOR?;5:YOUR ACCESS LEVEL" ;PATCH 2
 D ^DIR G EXIT:Y<1,EXIT:Y>5 ;PATCH 2
 S AQAOLIN=$S(Y=1:"INTRO",Y=2:"PATCH",Y=3:"MANUAL",Y=4:"ADMIN",1:"ACCESS") ;PATCH 2
 D @AQAOLIN
 G MENU
 ;
EXIT ; >>> eoj
 D KILL^AQAOUTIL W @IOF Q
 ;
 ;
INTRO ; >> SUBRTN to print intro to pkg
 S XQH="AQAO MAIN MENU" D EN^XQH
 N DIR S DIR(0)="E",DIR("A")="Press RETURN when ready to continue"
 D ^DIR
 Q
 ;
 ;
PATCH ; -- SUBRTN calls help frames detailing patches ;PATCH 2
 S XQH="AQAX QAI PATCHES" D EN^XQH Q  ;PATCH 2
 ;
 ;
MANUAL ; >> SUBRTN to list manuals available for pkg
 W @IOF,!!?20,"MANUALS AVAILABLE FOR YOUR USE",!!
 W !!,"QI TOOLS IN RPMS INDEX:"
 W ?30,"Sent with every distribution since July 1993."
 W !?30,"Lists all QI options in each RPMS package."
 W !!,"USER MANUAL:"
 W ?30,"For use by all QAI users;"
 W !?30,"Provides details of each menu option"
 W !?30,"and when to use each."
 W !!,"TECHNICAL MANUAL:"
 W ?30,"For site managers and RPMS developers;"
 W !?30,"Provides information on system structure, links"
 W !?30,"with other packages, and system requirements."
 W !!
 N DIR S DIR(0)="E",DIR("A")="Press RETURN when ready to continue"
 D ^DIR
 Q
 ;
 ;
ADMIN ; >> SUBRTN to list all pkg administrators and phone numbers
 W @IOF,!!?20,"QAI PACKAGE ADMINISTRATOR(S) FOR YOUR FACILITY",!!
 K AQAO S X=0
 F  S X=$O(^AQAO(9,X)) Q:X'=+X  D
 .Q:'$D(^AQAO(9,X,0))  Q:$P(^(0),U,4)]""  Q:$P(^(0),U,6)'="QA"
 .S AQAO(X)=""
 I '$D(AQAO) D  Q
 .W !!,"NO PACKAGE ADMINISTRATOR DEFINED!"
 .W "  NOTIFY YOUR SITE MANAGER IMMEDIATELY!!",!!
 S X=0
 F  S X=$O(AQAO(X)) Q:X=""  D
 .W !,"NAME:  ",$P(^VA(200,X,0),U)
 .W ?35,"OFFICE PHONE:  ",$P($G(^VA(200,X,.13)),U,2)
 N DIR S DIR(0)="E",DIR("A")="Press RETURN when ready to continue"
 D ^DIR
 Q
 ;
 ;
ACCESS ; >> SUBRTN to show user their access level
 W @IOF,!!?20,"YOUR ACCESS LEVEL IN THE QAI MGT SYSTEM",!!
 K DIC S L=0,DIC="^AQAO(9,",FLDS="[AQAO USER INQ]",BY="@NUMBER"
 S (TO,FR)=DUZ,DHD="@@",IOP="HOME" D EN1^DIP
 N DIR S DIR(0)="E",DIR("A")="Press RETURN when ready to continue"
 D ^DIR
 Q

AQAOVAR
AQAOVAR ; IHS/ORDC/LJF - MENU ENTRY AND EXIT ACTIONS ; [ 03/09/95  1:24 PM ]
 ;;1;QAI MANAGEMENT;**2**;AUG 15, 1994
 ;
 ;This rtn contains the entry and exit actions for the main QAI menu
 ;as well as common subrtns for other menus and options.
 ;
 Q
ENTER ;ENTRY POINT entry actions for AQAOMENU
 S Y=0,Y=$O(^DIC(9.4,"C","AQAO",Y)),AQAO("VERS")=^DIC(9.4,Y,"VERSION")
 S Y=$P(^DIC(9.4,Y,22,+AQAO("VERS"),0),U,2) X ^DD("DD")
 S AQAO("VERDT")=Y
 ;
 D ^XBCLS W !?18 F AQAO("I")=1:1:41 W "*"
 W !?18,"*",?58,"*",!?18,"*        INDIAN HEALTH SERVICE          *"
 W !?18,"*   QUALITY ASSESSMENT & IMPROVEMENT    *"
 W !?18,"*          MANAGEMENT SYSTEM            *"
 W !?18,"*       VERSION ",AQAO("VERS"),", ",AQAO("VERDT"),?58,"*"
 W !?18,"*",?58,"*",!?18 F AQAO("I")=1:1:41 W "*"
 ;
 I '$D(DUZ(2))!('$D(DUZ(0))) D  G XQUIT
 .W !!,"YOU MUST SIGN ON PROPERLY THROUGH THE KERNEL TO USE THE QAI"
 .W " MANAGEMENT SYSTEM!" S XQUIT=1
 S X=$P($G(^DIC(4,DUZ(2),0)),U) W !!?80-$L(X)\2,X
 I X="" W !!,"INVALID FACILITY; NOTIFY YOUR SITE MANAGER!" S XQUIT=""
 ;
 ; >>> check user's access to package
 K AQAOPT I '$D(^AQAO(9,DUZ,0)) G NOTUSER ;not in qi user file
 S AQAOUA("USER")=^AQAO(9,DUZ,0)
 I $P(AQAOUA("USER"),U,2)="" K AQAOPT G NOTUSER ;not activated
 I $P(AQAOUA("USER"),U,4)'="" K AQAOPT G NOTUSER ;inactivated
 G XQUIT:($P(AQAOUA("USER"),U,6)["Q") ;qi staff
 ;
 ; >>> set user's access by qi team
 S X=0 F  S X=$O(^AQAO(9,DUZ,"TM",X)) Q:X'=+X  D
 .Q:'$D(^AQAO(9,DUZ,"TM",X,0))  S Y=^(0) Q:Y=""
 .I $P(Y,U,2)="" K AQAOPT Q
 .S AQAOUA("USER",$P(Y,U))=$P(Y,U,2)
 .I $P(Y,U,2)>$G(AQAOUA("USER","ACCESS")) S AQAOUA("USER","ACCESS")=$P(Y,U,2) ;set highest access level
 ;
NOTUSER I '$D(AQAOUA("USER")) D
 .S XQUIT=""
 .W *7,!!?10,"**** YOU ARE NOT LISTED AS AN AUTHORIZED QI USER! ****"
 .W !?15,"**** PLEASE SEE YOUR QI STAFF FOR ACCESS ****",!! H 5
 ;
XQUIT W ! K X,Y
 Q
 ;
 ;
MENU ;ENTRY POINT  >>> entry action for all submenus
 S AQAO("TITLE")=$P($G(XQY0),U,2)
 I $L(AQAO("TITLE"))>2 W @IOF,!!?80-$L(AQAO("TITLE"))/2,AQAO("TITLE")
 S X=$P($G(^DIC(4,DUZ(2),0)),U)
 W !!?80-$L(X)\2,"(",X,")"
 K AQAO
 Q
 ;
PRTOPT ;ENTRY POINT  >>> exit action for print options
 Q:IOST'["C-"  ;PATCH 2
 K DIR S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR W @IOF
 K DIR Q
 ;
EXIT ;ENTRY POINT  >>> exit actions for AQAOMENU
 K AQAOCHK,AQAOUA,AQAOXYZ,AQAOINAC,AQAOENTR K ^TMP("AQAOCHK",$J)
 Q

AQAOZP2
AQAOZP2 ;IHS/ORDC/LJF - PATCH #2 DRIVER; [ 03/22/95  8:05 AM ]
 ;;1;QAI MANAGEMENT;**2**;AUGUST 15, 1994
 ;
 W !!?20,"QAI PATCH 2 DRIVER"
 W !! K DIR S DIR(0)="Y",DIR("B")="NO"
 S DIR("A")="Are you READY to proceed with this update"
 D ^DIR G EXIT:Y'=1
 ;
START ; -- Start of process to install patch #2
 ; -- install 2 print templates & 1 input template
 W !!,"First I need to run an init to install 3 templates:"
 W !?5,"Print templates: AQAO ACTION LIST"
 W !?5,"                 AQAO FINDINGS LIST"
 W !?5,"Input template:  AQAO RATE REVIEW"
 W !,"And to install Help Frames detailing patches",!!
 D ^AQAXINIT
 ;
 ; -- delete temp entry in package file
 W !!,"I will now delete the temporary entry in the PACKAGE file"
 W !,"used to install these templates and help frames.  .  ."
 S DA=$O(^DIC(9.4,"C","AQAX",0)) I DA="" W !,"No entry to DELETE!!"
 I DA]"" S DIK="^DIC(9.4," D ^DIK W !,"Entry DELETED.",!
 K DA,DIK
 ;
 ; -- update entry/exit actions for 2 options
 D CUMP2
 ;
 ;
EXIT ; -- eoj
 Q
 ;
CUMP2 ;EP -- to be called by future patches
 ; -edit entry & exit actions for 2 options
 W !,"I will now update the Entry & Exit Actions for options:"
 W !?5,"AQAO PKGLIST ACTION & AQAO PKGLIST FINDINGS"
 F AQAXI="AQAO PKGLIST ACTION","AQAO PKGLIST FINDINGS" D
 . S DA=$O(^DIC(19,"B",AQAXI,0)) Q:DA=""
 . S DIE=19,DR="20///S AQAOINAC="""";15///K AQAOINAC D PRTOPT^AQAOVAR"
 . D ^DIE
 K AQAXI,DA,DIE,DR W !,"Options UPDATED.",!
 Q

AQAQEDT
AQAQEDT ;IHS/ANMC/LJF - MAIN DRIVER FOR DATA ENTRY; [ 12/20/94  3:53 PM ]
 ;;2.2;STAFF CREDENTIALS;;01 OCT 1992
 ;
 ;This routine uses the QI Data Entry file to create data entry
 ;screens and controls editing of those screens.
 ;The calling option sends AQAQOPTN (option name) before calling rtn
 ;5/2/94 Routine modified to work with changes to QI Data Entry file
 ;needed by QAI Mgt. System.  Distributed in patch AQAO*1*1.
 ;
SETOPT K DIC S X=AQAQOPTN,DIC(0)="",DIC="^AQAQX("
 D ^DIC G END:Y=-1 S AQAQPT=+Y
 ;
 ;***> for each provider, choose pages and data items to enter/edit
 F  D  Q:$D(DIRUT)  Q:Y=-1
 .D GETPROV Q:X=U  Q:X=""
 .D PAGELOOP K DIRUT
 ;
END ;***> eoj
 D KILL^AQAQUTIL Q
 ;
 ;>>>>END OF MAIN ROUTINE; SUBRTNS TO FOLLOW<<<<<
 ;
GETPROV ;>>subrtn ask for provider & find/create entry in Credentialing file<<
 ;***> ask provider name
 K DIC S DIC("A")="Select PROVIDER NAME:  ",DIC(0)="AELMQZ"
 S (DIC,DLAYGO)=9002165 D ^DIC
 Q:X=U  Q:X=""  G GETPROV:Y=-1 S AQAQPRV=+Y
 S AQAQPRVN=$P(^DIC(16,AQAQPRV,0),U) ;provider name
 S AQAQPRVC="",Y=$P($G(^DIC(6,AQAQPRV,0)),U,4)
 I Y]"" S C=$P(^DD(6,2,0),U,2) D Y^DIQ S AQAQPRVC=Y ;provider class
 Q
 ;
 ;
PAGELOOP ;>>subrtn to get each page (screen), display items and do edit<<
 ;***> find all pages available to work on
 S AQAQPG=0,AQAQOPTT=$P(^AQAQX(AQAQPT,0),U,2)
 W @IOF,!?80-$L(AQAQOPTT)/2,AQAQOPTT
 W !?80-$L(AQAQPRVN)/2,AQAQPRVN
 W !?80-$L(AQAQPRVC)/2,AQAQPRVC
 W !!
 F  S AQAQPG=$O(^AQAQX(AQAQPT,"PG","B",AQAQPG)) Q:AQAQPG=""  D
 .K DIR S AQAQPN=0,DIR(0)="LO^0:"_AQAQPG
 .F  S AQAQPN=$O(^AQAQX(AQAQPT,"PG","B",AQAQPG,AQAQPN)) Q:AQAQPN=""  D
 ..Q:'$D(^AQAQX(AQAQPT,"PG",AQAQPN,0))
 ..S AQAQPTL=$P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,3)
 ..S AQAQP(AQAQPG)=AQAQPTL_U_AQAQPN W !?5,AQAQPG,") ",AQAQPTL
 ..Q
 ;
 ;***> choose page to work on
 W !!
 S DIR("A")="Choose category to edit (Enter 0 for ALL categories)"
 D ^DIR Q:$D(DIRUT)  G PAGELOOP:Y=-1 S Y=$E(Y,1,$L(Y)-1)
 I $D(^AQAQC(AQAQPRV,2)) S $P(^(2),U,3,4)=DT_U_DUZ ;editing user
 ;
 ;***> loop thru all pages selected
 K DIROUT
 I Y=0 S AQAQO="" F  S X=$O(AQAQP(X)) Q:X=""  S AQAQO=AQAQO_","_X
 E  S AQAQO=Y
 I AQAQO?1",".E S AQAQO=$E(AQAQO,2,99)
 F AQAQ=1:1 S Y=$P(AQAQO,",",AQAQ) Q:Y=""  Q:$D(DIROUT)  Q:$D(DUOUT)  D
 .S AQAQPTL=$P(AQAQP(Y),U),AQAQPN=$P(AQAQP(Y),U,2)
 .W @IOF,!?80-$L(AQAQPTL)/2,AQAQPTL ;page title
 .W !?80-$L(AQAQPRVN)/2,AQAQPRVN ;print provider name
 .W !?80-$L(AQAQPRVC)/2,AQAQPRVC,!! ;print provider class
 .W $P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,4),! ;page heading
 .K DIR S Y=$P(^AQAQX(AQAQPT,"PG",AQAQPN,0),U,2)
 .I Y]"" S C=$P(^DD(9002166.11,.02,0),U,2) D Y^DIQ S DIR("A")=Y
 .;
 .;***> display items and ask user for choice, and then edit via ^die
 .S AQAQTM=0
 .S AQAQSTR=$S('$D(^AQAQX(AQAQPT,"PG",AQAQPN,1)):"",1:^(1))
 .I $D(^AQAQX(AQAQPT,"PG",AQAQPN,2)) S DA=AQAQPRV X ^(2) Q  ;IHS/ORDC/LJF 10/5/93 change for QAI pkg
 .I $P(AQAQSTR,U)'="" D MULTFIND^AQAQEDTS Q  ;multiple field page
 .D ITEMFIND^AQAQEDTS:$P(AQAQSTR,U)="" ;multiple items on page
 .Q
 Q:$D(DIROUT)  Q:X="^^"
 G PAGELOOP
 ;>>end of PAGELOOP subrtn<<

AQAXI001
AQAXI001 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"DIE",1857,0)
 ;;=AQAO RATE REVIEW^2950313.1307^^9002167^^^^
 ;;^UTILITY(U,$J,"DIE",1857,"DR",1,9002167)
 ;;=Q;.13///^S X="`"_$P(^AQAO(2,$P(^AQAOC(D0,0),U,8),1),U,6);S:X]"" AQAORLX=$P(^AQAO(7,$P(^AQAOC(D0,1),U,3),0),U,2);.14///^S X="`"_DUZ;.18///^S X=DT;Q;.15///^S X="`"_$P(^AQAO(2,$P(^AQAOC(D0,0),U,8),1),U,4);
 ;;^UTILITY(U,$J,"DIE",1857,"DR",1,9002167,1)
 ;;=S:$P(^AQAO(8,$P(^AQAOC(D0,1),U,5),0),U,5)'=1 Y="@2";.12;@2;Q;.16///^S X="`"_$P(^AQAO(2,$P(^AQAOC(D0,0),U,8),1),U,5);S:$P(^AQAO(6,$P(^AQAOC(AQAOIFN,1),U,6),0),U,4)'=1 Y="@3";.19;@3;K AQAORLX;
 ;;^UTILITY(U,$J,"DIE",1857,"ROU")
 ;;=^AQAOT45
 ;;^UTILITY(U,$J,"DIE",1857,"ROUOLD")
 ;;=AQAOT45
 ;;^UTILITY(U,$J,"DIPT",4136,0)
 ;;=AQAO ACTION LIST^2950309.1413^^9002168.6^^^^
 ;;^UTILITY(U,$J,"DIPT",4136,"DXS",1,9.2)
 ;;=S DIP(1)=$S($D(^AQAO(6,D0,0)):^(0),1:"") S X=$P(DIP(1),U,2)="",DIP(2)=X S X="",DIP(3)=X S X=1,DIP(4)=X S X=" ("_$P(DIP(1),U,2)_")"
 ;;^UTILITY(U,$J,"DIPT",4136,"DXS",2,1)
 ;;=REFERRAL
 ;;^UTILITY(U,$J,"DIPT",4136,"DXS",2,2)
 ;;=PRACTITIONER-BASED
 ;;^UTILITY(U,$J,"DIPT",4136,"DXS",3,"I")
 ;;=INACTIVE
 ;;^UTILITY(U,$J,"DIPT",4136,"F",2)
 ;;=.01;C1;S1;L30~X DXS(1,9.2) S X=$S(DIP(2):DIP(3),DIP(4):X) W X K DIP;X;Z;"$S(ABBREVIATION="":"",1:" ("_ABBREVIATION_")")"~.03;C40~.04;"ACTION TYPE"~.05~
 ;;^UTILITY(U,$J,"DIPT",4136,"H")
 ;;=QI ACTION LIST
 ;;^UTILITY(U,$J,"DIPT",4136,"IOM")
 ;;=80
 ;;^UTILITY(U,$J,"DIPT",4136,"LAST")
 ;;=
 ;;^UTILITY(U,$J,"DIPT",4136,"ROU")
 ;;=^AQAOT57
 ;;^UTILITY(U,$J,"DIPT",4136,"ROUOLD")
 ;;=AQAOT57
 ;;^UTILITY(U,$J,"DIPT",4138,0)
 ;;=AQAO FINDINGS LIST^2950309.1354^^9002168.8^^^^
 ;;^UTILITY(U,$J,"DIPT",4138,"DXS",1,9.2)
 ;;=S DIP(2)=$C(59)_$S($D(^DD(9002168.8,.05,0)):$P(^(0),U,3),1:""),DIP(1)=$S($D(^AQAO(8,D0,0)):^(0),1:"") S X=$P($P(DIP(2),$C(59)_$P(DIP(1),U,5)_":",2),$C(59),1)
 ;;^UTILITY(U,$J,"DIPT",4138,"DXS",2,"I")
 ;;=INACTIVE
 ;;^UTILITY(U,$J,"DIPT",4138,"F",1)
 ;;=.01;C1;S1;L75;"FINDING NAME"~
 ;;^UTILITY(U,$J,"DIPT",4138,"F",2)
 ;;=S DIP(1)=$S($D(^AQAO(8,D0,0)):^(0),1:"") S X="("_$P(DIP(1),U,2)_")" W X K DIP;C5;"(ABBREVIATION)";Z;""("_ABBREVIATION_")""~.03;"REVIEW LEVELS";C40;L13~
 ;;^UTILITY(U,$J,"DIPT",4138,"F",3)
 ;;=X DXS(1,9.2) S X=X="",DIP(3)=X S X="",DIP(4)=X S X=1,DIP(5)=X S X="YES",X=$S(DIP(3):DIP(4),DIP(5):X) W X K DIP;C55;"EXCEPTION?";L10;Z;"$S(TYPE OF FINDING="":"",1:"YES")"~
 ;;^UTILITY(U,$J,"DIPT",4138,"F",4)
 ;;=.04;C67;L9~
 ;;^UTILITY(U,$J,"DIPT",4138,"H")
 ;;=QI FINDINGS LIST
 ;;^UTILITY(U,$J,"DIPT",4138,"IOM")
 ;;=80
 ;;^UTILITY(U,$J,"DIPT",4138,"LAST")
 ;;=
 ;;^UTILITY(U,$J,"DIPT",4138,"ROU")
 ;;=^AQAOT63
 ;;^UTILITY(U,$J,"DIPT",4138,"ROUOLD")
 ;;=AQAOT63
 ;;^UTILITY(U,$J,"HEL",1541,0)
 ;;=AQAX QAI PATCHES^QAI MGT SYSTEM PATCHES^2950313.0845^^
 ;;^UTILITY(U,$J,"HEL",1541,1,0)
 ;;=^^16^16^2950313^
 ;;^UTILITY(U,$J,"HEL",1541,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,2,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,3,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,4,0)
 ;;=                VERSION 1 PATCHES RELEASED & INSTALLED
 ;;^UTILITY(U,$J,"HEL",1541,1,5,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,6,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,7,0)
 ;;=       PATCH [1 ]:  Released December 1994
 ;;^UTILITY(U,$J,"HEL",1541,1,8,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,9,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,10,0)
 ;;=       PATCH [2 ]:  Released March 1995
 ;;^UTILITY(U,$J,"HEL",1541,1,11,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,12,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,13,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,14,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,15,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1541,1,16,0)
 ;;=For summary of changes included in a patch, select by number.
 ;;^UTILITY(U,$J,"HEL",1541,2,0)
 ;;=^9.22^2^2
 ;;^UTILITY(U,$J,"HEL",1541,2,1,0)
 ;;=1 ^AQAX QAI PATCH 1
 ;;^UTILITY(U,$J,"HEL",1541,2,2,0)
 ;;=2 ^AQAX QAI PATCH 2
 ;;^UTILITY(U,$J,"HEL",1542,0)
 ;;=AQAX QAI PATCH 2^QAI V1 PATCH 2^2950313.0844^^
 ;;^UTILITY(U,$J,"HEL",1542,1,0)
 ;;=^^20^20^2950313^
 ;;^UTILITY(U,$J,"HEL",1542,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,2,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,3,0)
 ;;= 1. Fixed automatic STUFFING of INITIAL occurrence REVIEW for those
 ;;^UTILITY(U,$J,"HEL",1542,1,4,0)
 ;;=    rate-based indicators set up that way.
 ;;^UTILITY(U,$J,"HEL",1542,1,5,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,6,0)
 ;;= 2. Fixed listings of ACTION & FINDING TABLES to include inactive entries.
 ;;^UTILITY(U,$J,"HEL",1542,1,7,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,8,0)
 ;;= 3. QUARTERLY PROGRESS REPORT for multiple indicators now totals cases
 ;;^UTILITY(U,$J,"HEL",1542,1,9,0)
 ;;=    correctly. Changed subheading "Hospital-wide Indicators" to

AQAXI002
AQAXI002 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 F I=1:2 S X=$T(Q+I) Q:X=""  S Y=$E($T(Q+I+1),4,999),X=$E(X,4,999) S:$A(Y)=126 I=I+1,Y=$E(Y,2,999)_$E($T(Q+I+1),5,999) S:$A(Y)=61 Y=$E(Y,2,999) X NO E  S @X=Y
Q Q
 ;;^UTILITY(U,$J,"HEL",1542,1,10,0)
 ;;=    "Facility-wide Indicators".
 ;;^UTILITY(U,$J,"HEL",1542,1,11,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,12,0)
 ;;= 4. While CREATING OCCURRENCES FROM a Q-MAN SEARCH template, patient's
 ;;^UTILITY(U,$J,"HEL",1542,1,13,0)
 ;;=    visit date is now used as the default occurrence date. This speeds up
 ;;^UTILITY(U,$J,"HEL",1542,1,14,0)
 ;;=    data entry and prevents case being created with no occurrence date.
 ;;^UTILITY(U,$J,"HEL",1542,1,15,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,16,0)
 ;;= 5. TICKLER REPORT now shows correct automatic entries by user.
 ;;^UTILITY(U,$J,"HEL",1542,1,17,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,18,0)
 ;;= 6. PRINTING multiple REVIEW WORKSHEETS no longer creates an error.
 ;;^UTILITY(U,$J,"HEL",1542,1,19,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1542,1,20,0)
 ;;= 7. Added these HELP FRAMES detailing patches and what they fixed.
 ;;^UTILITY(U,$J,"HEL",1543,0)
 ;;=AQAX QAI PATCH 1^QAI V1 PATCH 1^2950313.0829^^
 ;;^UTILITY(U,$J,"HEL",1543,1,0)
 ;;=^^11^11^2950313^
 ;;^UTILITY(U,$J,"HEL",1543,1,1,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1543,1,2,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1543,1,3,0)
 ;;= 1. Added change so STAFF CREDENTIALS can work on same machine as QAI.
 ;;^UTILITY(U,$J,"HEL",1543,1,4,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1543,1,5,0)
 ;;= 2. Fixed Occurrence Review process so DELETING A REVIEW will not cause an
 ;;^UTILITY(U,$J,"HEL",1543,1,6,0)
 ;;=    error.
 ;;^UTILITY(U,$J,"HEL",1543,1,7,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1543,1,8,0)
 ;;= 3. Fixed FACILITY-DEFINED REPORT FORMATS set up; now saves format
 ;;^UTILITY(U,$J,"HEL",1543,1,9,0)
 ;;=    correctly.
 ;;^UTILITY(U,$J,"HEL",1543,1,10,0)
 ;;= 
 ;;^UTILITY(U,$J,"HEL",1543,1,11,0)
 ;;= 4. Fixed algorithm that creates OCCURRENCE ID numbers.
 ;;^UTILITY(U,$J,"PKG",329,0)
 ;;=QAI PATCHES^AQAX^TEMP ENTRY FOR PATCHES
 ;;^UTILITY(U,$J,"PKG",329,22,0)
 ;;=^9.49I^1^1
 ;;^UTILITY(U,$J,"PKG",329,22,1,0)
 ;;=1^2950313
 ;;^UTILITY(U,$J,"PKG",329,22,"B",1,1)
 ;;=
 ;;^UTILITY(U,$J,"PKG",329,"DIE",0)
 ;;=^9.47^1^1
 ;;^UTILITY(U,$J,"PKG",329,"DIE",1,0)
 ;;=AQAO RATE REVIEW^9002167
 ;;^UTILITY(U,$J,"PKG",329,"DIPT",0)
 ;;=^9.46^2^2
 ;;^UTILITY(U,$J,"PKG",329,"DIPT",1,0)
 ;;=AQAO FINDINGS LIST^9002168.8
 ;;^UTILITY(U,$J,"PKG",329,"DIPT",2,0)
 ;;=AQAO ACTION LIST^9002168.6

AQAXINI1
AQAXINI1 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 ; LOADS AND INDEXES DD'S
 ;
 K DIF,DIK,D,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DFR,DTN,DIX,DZ D DT^DICRW S %=1,U="^",DSEC=1
 S NO=$P("I 0^I $D(@X)#2,X[U",U,%) I %<1 K DIFQ Q
ASK I %=1,$D(DIFQ(0)) W !,"SHALL I WRITE OVER FILE SECURITY CODES" S %=2 D YN^DICN S DSEC=%=1 I %<1 K DIFQ Q
 F X="DIE","DIP","HEL" D W Q:'$D(DIFQ)
 Q:'$D(DIFQ)  S %=2 W !!,"ARE YOU SURE EVERYTHING'S OK" D YN^DICN I %-1 K DIFQ Q
 I $D(DIFKEP) F DIDIU=0:0 S DIDIU=$O(DIFKEP(DIDIU)) Q:DIDIU'>0  S DIU=DIDIU,DIU(0)=DIFKEP(DIDIU) D EN^DIU2
 D DT^DICRW K ^UTILITY(U,$J),^UTILITY("DIK",$J) D WAIT^DICD
 S DN="^AQAXI" F R=1:1:2 D @(DN_$$B36(R)) W "."
 F  S D=$O(^UTILITY(U,$J,"SBF","")) Q:D'>0  K:'DIFQ(D) ^(D) S D=$O(^(D,"")) I D>0  K ^(D) D IX
DATA W "." S (D,DDF(1),DDT(0))=$O(^UTILITY(U,$J,0)) Q:D'>0
 I DIFQR(D) S DTO=0,DMRG=1,DTO(0)=^(D),Z=^(D)_"0)",D0=^(D,0),@Z=D0,DFR(1)="^UTILITY(U,$J,DDF(1),D0,",DKP=DIFQR(D)'=2 F D0=0:0 S D0=$O(^UTILITY(U,$J,DDF(1),D0)) S:D0="" D0=-1 Q:'$D(^(D0,0))  S Z=^(0) D I^DITR
 K ^UTILITY(U,$J,DDF(1)),DDF,DDT,DTO,DFR,DFN,DTN G DATA
 ;
W S Y=$P($T(@X),";",2) W !,"NOTE: This package also contains "_Y_"S",! Q:'$D(DIFQ(0))
 S %=1 W ?6,"SHALL I WRITE OVER EXISTING "_Y_"S OF THE SAME NAME" D YN^DICN I '% W !?6,"Answer YES to replace the current "_Y_"S with the incoming ones." G W
 S:%=2 DIFQ(X)=0 K:%<0 DIFQ
 Q
 ;
OPT ;OPTION
RTN ;ROUTINE DOCUMENTATION NOTE
FUN ;FUNCTION
BUL ;BULLETIN
KEY ;SECURITY KEY
HEL ;HELP FRAME
DIP ;PRINT TEMPLATE
DIE ;INPUT TEMPLATE
DIB ;SORT TEMPLATE
DIS ;SCREEN TEMPLATE
 ;
SBF ;FILE AND SUB FILE NUMBERS
IX W "." S DIK="A" F %=0:0 S DIK=$O(^DD(D,DIK)) Q:DIK=""  K ^(DIK)
 S DA(1)=D,DIK="^DD("_D_"," D IXALL^DIK
 I $D(^DIC(D,"%",0)) S DIK="^DIC(D,""%""," G IXALL^DIK
 Q
B36(X) Q $$N(X\(36*36)#36+1)_$$N(X\36#36+1)_$$N(X#36+1)
N(%) Q $E("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",%)
MSG ;
 I $P(^XMB(3.9,XMZ,0),U,7)'="X" Q
 S X=$S($D(^XMB(3.9,XMZ,2,XCN,0)):^(0),1:"") Q:X=""
M0 D M1 Q:$P(X,"$END MESSAGE")=""  D SAVE,NT G M0
NT S XCN=$O(^XMB(3.9,XMZ,2,XCN)) Q:XCN'?1.N  S X=^(XCN,0) Q
SAVE D NT Q:$E(X)="$"  S Y=X D NT Q:$E(X)="$"
 I $A(X)=126 S A0=X D NT S X=A0_$E(X,2,999) K A0
 S:% @Y=$E(X,2,999) G SAVE
 Q
M1 S Y=$E(X,2,4),%=0 I Y="DDD" S D=+$P(X,"(#",2),%=DIFQ(D) Q:D  S:$P(X,"(#",2)["FILE SECURITY" %=DSEC Q
 Q:Y="END"
 I Y="DTA" S %=DIFQR(D) Q
 I (Y="OR ")!(Y="PKG") S %=1 Q
 I $T(@Y)]"" S %=1 Q
 Q

AQAXINI2
AQAXINI2 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 ;
 ;
 K ^UTILITY("DIFROM",$J),DIC S DIDUZ=0 S:$D(DUZ)#2 DIDUZ=DUZ S DUZ=.5
 I $D(^DIC(9.2,0))#2,^(0)?1"HEL".E S (DIC,DLAYGO)=9.2,N="HEL",DIC(0)="LX" G ADD
 Q
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R'>0  S X=$P(^(R,0),U,1) W "." K DA D ^DIC I Y>0,'$D(DIFQ(N))!$P(Y,U,3) S ^UTILITY("DIFROM",$J,N,X)=+Y K ^DIC(9.2,+Y,1),^(2),^(3),^(10) S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y D %XY^%RCR
 S DIK=DIC
HELP S R=$O(^UTILITY("DIFROM",$J,N,R)) Q:R=""  W !,"'"_R_"' Help Frame filed." S DA=^(R)
 F X=0:0 S X=$O(^DIC(9.2,DA,2,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$P(I,U,2) S:Y]"" Y=$O(^DIC(9.2,"B",Y,0)) S ^(0)=$P(^DIC(9.2,DA,2,X,0),U,1)_U_$S(Y>0:Y,1:"")_U_$P(^(0),U,3,99)
 S I=0 F X=0:0 S X=$O(^DIC(9.2,DA,10,X)) Q:'X  I $D(^(X,0)) S Y=$P(^(0),U),Y=$S(Y]"":$O(^MAG("B",Y,0)),1:0) S:Y $P(^DIC(9.2,DA,10,X,0),U)=Y,I=I+1,%=X I 'Y K ^DIC(9.2,DA,10,X,0)
 I I S $P(^DIC(9.2,DA,10,0),U,3,4)=%_U_I
IX D IX1^DIK G HELP
 ;
U I $D(DIRUT) S DIFQ=1
 W ! Q
REP S DIR(0)="Y",DIR("A")="Shall I change the NAME of the file to "_DIF
 S DIR("??")="^D REP^DIFROMH1",DIR("B")="NO" D ^DIR G U:$D(DIRUT)
 I Y S DIE=1,DIFQ=0,DA=N,DR=".01////"_DIF D ^DIE Q
 S DIR("A")="Shall I replace your file with mine"
 S DIR("??")="^D AG^DIFROMH1" D ^DIR G U:$D(DIRUT)!'Y
 S DIU(0)="E",DIR("A")="Do you want to keep the Data"
 S DIR("??")="^D CHG^DIFROMH1" D ^DIR G U:$D(DIRUT)
 S:'Y DIU(0)=DIU(0)_"D"
 S DIR("A")="Do you want to keep the Templates"
 S DIR("??")="^D TEMP^DIFROMH1" D ^DIR G U:$D(DIRUT) S:'Y DIU(0)=DIU(0)_"T"
 S DIFQ(N)=1,DIFKEP(N)=DIU(0) W !?15," (",DIF,") " Q

AQAXINI3
AQAXINI3 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 ;
 ;
 K ^UTILITY("DIFROM",$J) S DIC(0)="LX",(DIC,DLAYGO)=3.6,N="BUL" D ADD:$D(^XMB(3.6,0))
 S X=0 F R=0:0 S X=$O(^UTILITY("DIFROM",$J,N,X)) Q:X=""  W !,"'",X,"' BULLETIN FILED -- Remember to add mail groups for new bulletins."
 I $D(^DIC(9.4,0))#2,^(0)?1"PACK".E S N="PKG",(DIC,DLAYGO)=9.4 D ADD
 G NP:'$D(DA) S %=+$O(^DIC(9.4,DA,22,"B",DIFROM,0)) I $D(^DIC(9.4,DA,22,%,0)) S $P(^(0),U,3)=DT
 I $D(^DIC(9.4,DA,0))#2 S %=$P(^(0),U,4) I %]"" S %=$O(^DIC(9.2,"B",%,0)) S:%]"" $P(^DIC(9.4,DA,0),U,4)=%
OR I $D(^ORD(100.99))&$O(^UTILITY(U,$J,"OR","")) D EN^AQAXINI4
NP K DIC,^UTILITY("DIFROM",$J) S DIC(0)="LX" I $D(^DIC(19,0))#2,^(0)?1"OPTION".E S (DIC,DLAYGO)=19,N="OPT" D ADD,OP
 I $D(^DIC(19.1,0))#2,($P(^(0),U)?1"SECUR".E)!($P(^(0),U)="KEY") S (DIC,DLAYGO)=19.1,N="KEY" D ADD K ^UTILITY("DIFROM",$J)
 I $D(^DIC(9.8,0))#2,^(0)?1"ROUTINE^".E S (DIC,DLAYGO)=9.8,N="RTN" D ADD
 S DIC=.5,DLAYGO=0,N="FUN" D ADD
 S DIC("S")="I $P(^(0),U,4)=DIFL" F N="DIPT","DIBT","DIE" S DIC=U_N_"(" D ADD
 K DIC("S") S N="DIST(.404,",DIC=U_N,DLAYGO=.404 D ADD
 S DIC("S")="I $P(^(0),U,8)=DIFL",N="DIST(.403,",DIC=U_N,DLAYGO=.403 D ADD
 K ^UTILITY(U,$J),DIC,DLAYGO F DIFR="DIE","DIPT" D DIEZ
 K ^UTILITY("DIFROM",$J) Q
DIEZ I ^DD("VERSION")>17.4,'$D(DISYS) D OS^DII
 E  S DISYS=^DD("OS")
 Q:'$D(^DD("OS",DISYS,"ZS"))
 S DIFR1=""
DZ1 S DIFR1=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1)) Q:DIFR1=""
 F DIFR2=0:0 S DIFR2=$O(^UTILITY("DIFROM",$J,DIFR,DIFR1,DIFR2)) Q:'DIFR2  S Y=DIFR2 I $D(@(U_DIFR_"(Y,""ROU"")")) K ^("ROU") I $D(^("ROUOLD")) S X=^("ROUOLD"),DMAX=^DD("ROU") D:X]"" @("EN^DI"_$E(DIFR,3)_"Z")
 G DZ1
 ;
OP S R=$O(^UTILITY("DIFROM",$J,N,R)) I R="" K ^UTILITY("DIFROM",$J) G Q
 W !,"'"_R_"' Option Filed" S DA=+^UTILITY("DIFROM",$J,N,R) G:$P(^(R),U,2,3)="XUCORE^"!($P(^(R),U,2,3)="XUCOMMAND^") OP
 I $D(^DIC(19,DA,220)) S %=$P(^(220),U) S:%]"" %=$O(^XMB(3.6,"B",%,0)) S $P(^DIC(19,DA,220),U)=%,%=$P(^(220),U,3) S:%]"" %=$O(^XMB(3.8,"B",%,0)) S $P(^DIC(19,DA,220),U,3)=%
 S %=$P(^DIC(19,DA,0),U,12) S:%]"" %=$O(^DIC(9.4,"B",%,0))
 S $P(^DIC(19,DA,0),U,12)=%,%=$P(^(0),U,7),(DZ,DIX)=0
 D:$D(^DIC(19,DA,10,"B")) KAD(DA) S:%]"" %=$O(^DIC(9.2,"B",%,0)) S $P(^DIC(19,DA,0),U,7)=%,%=$P(^(0),U,4),%="MOQXL"[% K ^(10,"B"),^("C")
 F X=0:0 S X=$O(^DIC(19,DA,10,X)) Q:'X  S I=$S($D(^(X,0)):^(0),1:0),Y=$S($D(^(U)):^(U),1:"") K ^DIC(19,DA,10,X) I Y]"",% S D=$O(^DIC(19,"B",Y,0)) I D S ^DIC(19,DA,10,X,0)=D_U_$P(I,U,2,9),DZ=DZ+1,DIX=X
 S:% ^DIC(19,DA,10,0)="^19.01PI^"_DIX_U_DZ D IX1^DIK G OP
 ;
ADD F R=0:0 S R=$O(^UTILITY(U,$J,N,R)) Q:R=""  S X=$P(^(R,0),U),DIFL=$S(N="DIST(.403,":$P(^(0),U,8),N="DIST(.404,":$P(^(0),U,2),1:$P(^(0),U,4)) W "." K DA D ^DIC I Y>0,'$D(DIFQ($E(N,1,3)))!$P(Y,U,3) S Y=Y_U D A
Q Q
A I N="BUL" K % S %(0)=$G(@(DIC_"+Y,2,0)")) F %=0:0 S %=$O(@(DIC_"+Y,2,%)")) Q:'%  S %(%)=$G(^(%,0))
 K:N'="KEY"&(N'="OPT") @(DIC_"+Y)") S ^UTILITY("DIFROM",$J,N,X)=Y S:$E(N,1,2)="DI" ^(X,+Y)="" S:N="PKG" DIFROM(0)=+Y Q:$P(Y,U,2,3)="XUCORE^"!($P(Y,U,2,3)="XUCOMMAND^")
 I N="BUL",%(0)]"" S @(DIC_"+Y,2,0)")=%(0) F %=0:0 S %=$O(%(%)) Q:'%  S @(DIC_"+Y,2,%,0)")=%(%)
 I $E(N,1,2)="DI",('DIFL)!('$D(^DD(+DIFL))) W !,"**WARNING--"_$S(N="DIE":"INPUT",N="DIPT":"PRINT",N="DIBT":"SORT",1:"FORM or BLOCK")_" template "_$P(Y,U,2)_" has been installed,",!,"but associated file "_DIFL_" not on your system!"
 I N="OPT" S:$P(^DIC(19,+Y,0),U,6)]"" DIOPT=$P(^(0),U,6) I $O(^UTILITY(U,$J,N,R,1,0)) K ^DIC(19,+Y,1)
 I N="DIST(.403," D BLK
 S %X="^UTILITY(U,$J,N,R,",%Y=DIC_"+Y,",DA=+Y,DIK=DIC D %XY^%RCR
 D IX1^DIK:N'="OPT" I N="OPT",$D(DIOPT) S:$P(^DIC(19,DA,0),U,6)="" $P(^(0),U,6)=DIOPT K DIOPT
 Q
BLK F J=0:0 S J=$O(^UTILITY(U,$J,N,R,40,J)) Q:'J  I $D(^(J,0)) S %=$P(^(0),U,2) S:%]"" %=$O(^DIST(.404,"B",%,0)) S:% $P(^UTILITY(U,$J,N,R,40,J,0),U,2)=% D B1
 K A0,A1,A2,J,L Q
B1 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,40,L)) Q:'L  S A0=$G(^(L,0)),%=$P(A0,U) I %]"" S %=$O(^DIST(.404,"B",%,0)) I % S $P(A0,U)=%,^UTILITY(U,$J,N,R,40,J,"BLK",%,0)=A0
 S A0=$G(^UTILITY(U,$J,N,R,40,J,40,0)) Q:A0=""  K ^UTILITY(U,$J,N,R,40,J,40) S (A1,A2)=0
 F L=0:0 S L=$O(^UTILITY(U,$J,N,R,40,J,"BLK",L)) Q:'L  S ^UTILITY(U,$J,N,R,40,J,40,L,0)=^(L,0),A1=L,A2=A2+1
 S $P(A0,U,3,4)=A1_U_A2,^UTILITY(U,$J,N,R,40,J,40,0)=A0 K ^UTILITY(U,$J,N,R,40,J,"BLK")
 Q
KAD(D0) N D1,X
 S X=0 F  S X=$O(^DIC(19,D0,10,"B",X)) Q:X'>0  S D1=0 F  S D1=$O(^DIC(19,D0,10,"B",X,D1)) Q:D1'>0  K ^DIC(19,"AD",X,D0,D1)
 Q

AQAXINI4
AQAXINI4 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 ;
 ;
EN S DA(1)=1,DIK="^ORD(100.99,1,5," I $D(^ORD(100.99,1,5,DA)) D ^DIK
 S %X="^UTILITY(U,$J,""OR"","_$O(^UTILITY(U,$J,"OR",""))_",",%Y=DIK_DA_","
 S:'$D(^ORD(100.99,1,5,0)) ^(0)="^100.995P^^" S $P(^(0),U,3,4)=DA_U_($P(^(0),U,4)+1)
 D %XY^%RCR S $P(^ORD(100.99,1,5,DA,0),U)=DA,%=$P(^(0),U,4)
 I %]"" S %=$O(^ORD(100.98,"B",%,0)) I %>0 S $P(^ORD(100.99,1,5,DA,0),U,4)=%
 D OR
 S DA(1)=1 D IX1^DIK
 Q
OR S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,1,N)) Q:'N  S X=$P(^(N,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,0)=% S X=N,I=I+1,(R,J)=0,Y="" D OR1
 S:I $P(^ORD(100.99,1,5,DA,1,0),U,3,4)=X_U_I S (N,I)=0,X=""
 F  S N=$O(^ORD(100.99,1,5,DA,5,N)) Q:'N  S X=$P(^(N,0),U,3) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% $P(^ORD(100.99,1,5,DA,5,N,0),U,3)=% S X=N,I=I+1
 S:I $P(^ORD(100.99,1,5,DA,5,0),U,3,4)=X_U_I K N,R,X,Y,I,J
 Q
OR1 N X F  S R=$O(^ORD(100.99,1,5,DA,1,N,1,R)) Q:'R  S X=$P(^(R,0),U) I X]"" S %=$O(^ORD(101,"B",X,0)) D:'% ADDP S:% ^ORD(100.99,1,5,DA,1,N,1,R,0)=% S Y=R,J=J+1
 S:J $P(^ORD(100.99,1,5,DA,1,N,1,0),U,3,4)=Y_U_J
 Q
ADDP N I,J,N,R,DA,DLAYGO S %=""
 S DIC="^ORD(101,",DIC(0)="LX",DLAYGO=101 D FILE^DICN K DIC Q:Y=-1  S %=+Y Q

AQAXINI5
AQAXINI5 ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 K ^UTILITY("DIF",$J) S DIFRDIFI=1 F I=1:1:0 S ^UTILITY("DIF",$J,DIFRDIFI)=$T(IXF+I),DIFRDIFI=DIFRDIFI+1
 Q
IXF ;;QAI PATCHES^AQAX

AQAXINIS
AQAXINIS ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
PAC(PKG,VER) ; called from package init (DIFROM7 created this routine)
 ; PKG = $T(IXF) of the INIT routine.
 ; VER is an array that is contained in DIFROM from the INIT routine
 ;
 N %,%I,%H,DATE,DIFROM,NOW,PACKAGE,RUN,SERVER,SITE,START,X,XMDUZ,XMSUB,XMTEXT,XMY,Y K ^TMP("AQAXINIS",$J)
 ;
 ; Site tracking updates only occur if run in a VA production primary domain
 ; account.
 I $G(^XMB("NETNAME"))'[".VA.GOV" Q
 Q:'$D(^%ZOSF("UCI"))  Q:'$D(^%ZOSF("PROD"))
 X ^%ZOSF("UCI") I Y'=^%ZOSF("PROD") Q
 ;
 S SERVER="S.A5CSTS@FORUM.VA.GOV"
 S PACKAGE=$P($P(PKG,";",3),U)
 S SITE=$G(^XMB("NETNAME"))
 S START=$P($G(^DIC(9.4,VER(0),"PRE")),U,2) I '$L(START) S START="Unknown"
 D  ; check if ok to use kernel functions
 .S X="XLFDT" X ^%ZOSF("TEST") I $T D  Q
 ..S NOW=$$HTFM^XLFDT($H)
 ..S RUN="Unknown" I START S RUN=$$FMDIFF^XLFDT(NOW,START,3)
 ..S START=$$FMTE^XLFDT(START)
 ..S DATE=NOW\1
 ..S NOW=$$FMTE^XLFDT(NOW)
 .D NOW^%DTC S NOW=%,DATE=X
 .S RUN="" ; don't bother to compute
 .S Y=START D DD^%DT S START=Y
 .S Y=NOW D DD^%DT S NOW=Y
 ;
 ; Message for server
 S ^TMP("AQAXINIS",$J,1,0)="PACKAGE INSTALL"
 S ^TMP("AQAXINIS",$J,2,0)="SITE: "_SITE
 S ^TMP("AQAXINIS",$J,3,0)="PACKAGE: "_PACKAGE
 S ^TMP("AQAXINIS",$J,4,0)="VERSION: "_VER
 S ^TMP("AQAXINIS",$J,5,0)="Start time: "_START
 S ^TMP("AQAXINIS",$J,6,0)="Completion time: "_NOW
 S ^TMP("AQAXINIS",$J,7,0)="Run time: "_RUN
 S ^TMP("AQAXINIS",$J,8,0)="DATE: "_DATE
 ;
 ; Data is sent to server on FORUM - S.A5CSTS
 S XMY(SERVER)="",XMDUZ=.5,XMTEXT="^TMP(""AQAXINIS"",$J,",XMSUB=PACKAGE_" VERSION "_VER_" INSTALLATION"
 D ^XMD
 K ^TMP("AQAXINIS",$J)
 Q

AQAXINIT
AQAXINIT ; ; 13-MAR-1995
 ;;1;QAI PATCHES;;MAR 13, 1995
 ;
 K DIF,DIFQ,DIFQR,DIFQN,DIK,DDF,DDT,DTO,D0,DLAYGO,DIC,DIDUZ,DIR,DA,DIFROM,DFR,DTN,DIX,DZ,DIRUT,DTOUT,DUOUT
 S U="^",DIFQ=0,DIFROM="1" W !,"This version (#1) of 'AQAXINIT' was created on 13-MAR-1995"
 W !?9,"(at DSDHQ1/DEV, by VA FileMan V.20.0)",!
 I $D(^DD("VERSION")),^("VERSION")'<20 G GO
 W !,"FIRST, I'LL FRESHEN UP YOUR VA FILEMAN...." D N^DINIT
 I ^DD("VERSION")<20 W !,"BUT I NEED VERSION 20 OF THE VA FILEMAN!" G Q
GO ;
EN ; ENTER HERE TO BYPASS THE PRE-INIT PROGRAM
 S DIFQ=0 K DIRUT,DTOUT,DUOUT
 F DIFRIR=1:1:1 S DIFRRTN="^AQAXINI"_$E("5",DIFRIR) D @DIFRRTN
 W:0 !,"I AM GOING TO SET UP THE FOLLOWING FILE:" F I=1:2:0 S DIF(I)=^UTILITY("DIF",$J,I) D 1 G Q:DIFQ!$D(DIRUT) K DIF(I)
 S DIFROM="1" D PKG:'$D(DIFROM(0)),^AQAXINI1 G Q:'$D(DIFQ) S DIK(0)="AB"
 F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),DIK=$P(%,";",5),N=$P(%,";",3),D=$P(%,";",4)_U_N D D K DIFQ(N)
 K DIFQR D ^AQAXINI2,^AQAXINI3
 L  S DUZ=DIDUZ W:0 !,$C(7),"OK, I'M DONE.",!,"NO"_$P("TE THAT FILE",U,DSEC)_" SECURITY-CODE PROTECTION HAS BEEN MADE"
 I DIFROM F DIF=1:2:0 S %=^UTILITY("DIF",$J,DIF),N=+$P(%,";",3) I N,$P(%,";",8)="y" S ^DD(N,0,"VR")=DIFROM
 I DIFROM(0)>0 F %="PRE","INI","INIT" S:$D(DIFROM(%)) $P(^DIC(9.4,DIFROM(0),%),U,2)=DIFROM(%)
 I $G(DIFQN) S $P(^(0),U,3,4)=$P(DIFQN,U,2)_U_($P(^DIC(0),U,4)+DIFQN) K DIFQN
 I DIFROM,$D(^%ZTSK) S X="AQAXINIS" X ^%ZOSF("TEST") D:$T PAC^AQAXINIS($T(IXF),.DIFROM)
 S:DIFROM(0)>0 ^DIC(9.4,DIFROM(0),"VERSION")=DIFROM G Q^DIFROM0
D S:$D(^DIC(+N,0))[0 ^(0)=D S X=$D(@(DIK_"0)")),^(0)=D_U_$S(X#2:$P(^(0),U,3,9),1:U)
 S DIFQR=DIFQR(+N) I ^DD("VERSION")>17.5,$D(^DD(+N,0,"DIK"))#2 S X=^("DIK"),Y=+N,DMAX=^DD("ROU") D EN^DIKZ
 I DIFQR D IXALL^DIK:$O(@(DIK_"0)")) W "."
 Q
R G REP^AQAXINI2
 ;
1 S N=+$P(DIF(I),";",3),DIF=$P(DIF(I),";",4),S=$P(DIF(I),";",5)
 W !!?3,N,?13,DIF,$P("  (Partial Definition)",U,$P(DIF(I),";",6)),$P("  (including data)",U,$P(DIF(I),";",13)="y") S Z=$S($D(^DIC(N,0))#2:^(0),1:"")
 I Z="" S DIFQ(N)=1,DIFQN=$G(DIFQN)+1_U_N G S
 I $L($P(Z,DIF)) W $C(7),!,"*BUT YOU ALREADY HAVE '",$P(Z,U),"' AS FILE #",N,"!" D R Q:DIFQ  G S:$D(DIFKEP(N)),1
 S DIFQ(N)=$P(DIF(I),";",7)'="n"
 I $L(Z) W $C(7),!,"Note:  You already have the '",$P(Z,U),"' File." S DIFQ(0)=1
 S %=$E(^UTILITY("DIF",$J,I+1),4,245) I %]"" X % S DIFQ(N)=$T W:'$T !,"Screen on this Data Dictionary did not pass--DD will not be installed!" G S
 I $L(Z),$P(DIF(I),";",10)="y" S DIR("A")="Shall I write over the existing Data Definition",DIR("??")="^D DD^DIFROMH1",DIR("B")="YES",DIR(0)="Y" D ^DIR S DIFQ(N)=Y
S S DIFQR(N)=0 Q:$P(DIF(I),";",13)'="y"!$D(DIRUT)
 I $P(DIF(I),";",15)="y",$O(@(S_"0)"))>0 S DIF=$P(DIF(I),";",14)="o",DIR("A")="Want my data "_$P("merged with^to overwrite",U,DIF+1)_" yours",DIR("??")="^D DTA^DIFROMH1",DIR(0)="Y" D ^DIR S DIFQR(N)=$S('Y:Y,1:Y+DIF) Q
 S %=$P(DIF(I),";",14)="o" W !,$C(7),"I will ",$P("MERGE^OVERWRITE",U,%+1)," your data with mine." S DIFQR(N)=%+1
 Q
Q W $C(7),!!,"NO UPDATING HAS OCCURRED!" G Q^DIFROM0
 ;
PKG S X=$P($T(IXF),";",3),DIC="^DIC(9.4,",DIC(0)="",DIC("S")="I $P(^(0),U,2)="""_$P(X,U,2)_"""",X=$P(X,U) D ^DIC S DIFROM(0)=+Y K DIC
 Q
 ;
IXF ;;QAI PATCHES^AQAX;297
ERX W $C(7),!!,"This INIT was built as a Network Mail Message and can ONLY be installed",!,"within the Mail system!!" G Q