10:38 AM 23-JUN-95 QAI PATCH 1-3 AQAOAPA AQAOAPA ; IHS/ORDC/LJF - ENTER NEW ACTION PLAN ; [ 05/11/95 3:13 PM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn contains code for user interface in adding a new action ;plan or editing one already created. ; INDICATR ; >>> ask user for indicator tied to this action plan S AQAOIND=$$IND^AQAOLKP G EXIT:AQAOIND=U,EXIT:AQAOIND<1 S AQAOINDN=$P(AQAOIND,U,2),AQAOIND=+AQAOIND ; CATEGORY ; >>> ask user for action category to be tied to this action plan W !! K DIR S DIR(0)="PO^9002168.6:EMZQ" S DIR("A")="Select ACTION CATEGORY" D ^DIR G INDICATR:X="",EXIT:$D(DIRUT),CATEGORY:Y=-1 S AQAOCT=+Y,AQAOCTN=$P(Y,U,2) ; NUMBER ; >>> get new action plan number S AQAOAPN=$$NEWAP^AQAOCID I AQAOAPN="" D G EXIT .W !!,"COULD NOT GENERATE ACTION PLAN #; SEE SITE MANAGER" W !!!,"I will create Action Plan #",AQAOAPN,": ",AQAOCTN W !?40,"For INDICATOR: ",AQAOINDN,! ; ASK ; >>> ask if user is sure wants to add plan W !! K DIR S DIR(0)="YO",DIR("B")="YES" S DIR("A")="ARE YOU SURE YOU WISH TO ADD THIS ACTION PLAN" D ^DIR G EXIT:$D(DIRUT),INDICATR:Y=0 ; ADDPLAN ; >>> add action plan K DD,DO,DIC S X=AQAOAPN,DIC="^AQAO(5,",DIC(0)="" S DIC("DR")=".02////"_AQAOCT_";.05////1;.08////"_DUZ_";.09////"_DT_";.12////"_DUZ(2)_";.14////"_AQAOIND L +(^AQAO(5,0)):1 I '$T D G EXIT . W !!,*7,"CANNOT ADD; ANOTHER USER IS ADDING. TRY AGAIN.",! D FILE^DICN L -(^AQAO(5,0)) S AQAOPLAN=+Y ; EDITPLAN ; >> drop user into editing the action plan W !! L +^AQAO(5,AQAOPLAN):1 I '$T D G EXIT .W !!,"CANNOT EDIT; ANOTHER USER EDITING THIS ACTION PLAN.",! K DIE S DIE="^AQAO(5,",DA=AQAOPLAN,DR="[AQAO PLAN EDIT]" D ^DIE L -^AQAO(5,AQAOPLAN) G EXIT:$D(DTOUT),EXIT:$D(DUOUT) W !!,"ACTION PLAN CREATION COMPLETE . . ",!! G INDICATR ; EXIT ; >> eoj D KILL^AQAOUTIL Q ; ; EDIT ;ENTRY POINT for option to update action plan ;called by option AQAO ACTPLAN UPDATE D UPDATE^AQAOHAPL W !! K DIC S DIC="^AQAO(5,",DIC(0)="AEMZQ" S DIC("S")="I $P(^AQAO(5,Y,0),U,6)="""" D ACTCHK^AQAOSEC I $D(AQAOCHK(""OK""))" S DIC("A")="Enter ACTION PLAN NUMBER: " D ^DIC K AQAOCHK("OK") W ! G EXIT:X="",EXIT:X=U,EDIT:Y=-1 S AQAOPLAN=+Y ; ; >> drop user into editing the action plan W !! L +^AQAO(5,AQAOPLAN):1 I '$T D G EDIT .W !!,"CANNOT EDIT; ANOTHER USER EDITING THIS ACTION PLAN.",! K DIE S DIE="^AQAO(5,",DA=AQAOPLAN,DR="[AQAO PLAN EDIT]" D ^DIE I $G(AQAOSTAT)>2,$G(AQAOSTAT)<9 D .I $P(^AQAO(5,AQAOPLAN,0),U,4)]"",$P(^(0),U,4)>DT Q ;PATCH 3 .W !! K DIR S DIR(0)="Y",DIR("B")="YES" .S DIR("A")="Do you wish to CLOSE this Action Plan" .S DIR("?",1)="Answer YES to complete the processing of this plan." .S DIR("?",2)="Answer NO to allow continued editing of this plan." .S DIR("?",3)="Once closed, you must use the REOPEN option to edit" .S DIR("?",4)="it further.",DIR("?")=" " .D ^DIR Q:Y'=1 .S DIE="^AQAO(5,",DA=AQAOPLAN .S DR=".06////"_DT_";.11////"_$P(^VA(200,DUZ,0),U) D ^DIE .W !!,"ACTION CLOSED!",! L -^AQAO(5,AQAOPLAN) G EXIT:$D(DTOUT),EXIT:$D(DUOUT) D PRTOPT^AQAOVAR G EDIT AQAOCHK AQAOCHK ; IHS/ORDC/LJF - CHECK OCC NEEDING REVIEW ; [ 05/10/95 3:16 PM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn is main driver for the Introductory Message upom entrance ;to main QAI menu. It is also called from the Tickler Report option. ;This rtn finds all occurrences needing some action by the user who ;is signed on. QI staff members see all occurrences pending. ; ; AQAOXYZ="ALL" for QI staff which see all occurrences ; AQAOXYZ(1,TEAM IFN) ; AQAOXYZ(2,INDICATOR IFN) for entries in AQAOXYZ(1,TEAM IFN) ; array for occ counts AQAOXYZ(3, ; second subscript: 1=initial review needed ; 2=personal referral ; 3=referral to team ; 4=reviewed, not closed ; 5=pending action plans ; ENTRY ;ENTRY POINT to build array counting occ needing review ;called by main menu option AQAOMENU and by AQAOCHK2 W !!,*7,"Checking for OCCURRENCES & ACTION PLANS you need to review" W ". . . . ." ; S AQAODUZ=DUZ K AQAOXYZ K ^TMP("AQAOCHK",$J) ;start clean I $P(AQAOUA("USER"),U,6)]"" S AQAOXYZ="ALL" ;qi staff sees all ; ; >>> find indicators user has access to ; >> find all teams user has write access to S AQAOX=0 F S AQAOX=$O(^AQAO(9,AQAODUZ,"TM",AQAOX)) Q:AQAOX'=+AQAOX D .Q:$P(^AQAO(9,AQAODUZ,"TM",AQAOX,0),U,2)'=2 ;need write access .S AQAOY=$P(^AQAO(9,AQAODUZ,"TM",AQAOX,0),U) .S AQAOXYZ(1,AQAOY)="" .; .; >> find all indicators for this team .S AQAOIND=0 .F S AQAOIND=$O(^AQAO(2,"AC",AQAOY,AQAOIND)) Q:AQAOIND="" D ..S AQAOXYZ(2,AQAOIND)="" ;save list of indicators ; ; >> no team write access I '$D(AQAOXYZ)#2,'$D(AQAOXYZ(1)) W !!,"*** NONE FOUND ***" G END^AQAOCHK2 ; OCC ;EP >>> loop thru open occurrences then check if on indicator list S AQAOIFN=0 F S AQAOIFN=$O(^AQAOC("AD",0,AQAOIFN)) Q:AQAOIFN="" D .Q:'$D(^AQAOC(AQAOIFN,0)) Q:$P(^(0),U,9)'=DUZ(2) .S AQAOIND=$P(^AQAOC(AQAOIFN,0),U,8),AQAODT=$P(^(0),U,4) .S AQAOAC=$P($G(^AQAOC(AQAOIFN,1)),U,6) ;initial review action .I AQAOAC="" S X=1 D SET^AQAOCHK0 Q ;needs initial review .S (AQAOREV,AQAOLST)=0 .F S AQAOREV=$O(^AQAOC(AQAOIFN,"REV",AQAOREV)) Q:AQAOREV'=+AQAOREV D ..Q:$P(^AQAOC(AQAOIFN,"REV",AQAOREV,0),U,7)="" ;no action entered ..S AQAOLST=AQAOREV ;find last review .S AQAOAC=$S(AQAOLST=0:AQAOAC,1:$P(^AQAOC(AQAOIFN,"REV",AQAOLST,0),U,7)) .I $P(^AQAO(6,AQAOAC,0),U)'?1"REFER".E S X=4 D SET^AQAOCHK0 Q ;revwd .S AQAOREF=$S(AQAOLST=0:$P(^AQAOC(AQAOIFN,1),U,9),1:$P(^AQAOC(AQAOIFN,"REV",AQAOLST,0),U,9)) ;set referred to variable .S X=$S(AQAOREF="":4,$P(AQAOREF,";",2)="AQAO(9,":2,1:3) .I X=4 D SET^AQAOCHK0 Q .D REFSET1^AQAOCHK0 .I AQAOLST=0 D ;find additional referrals off initial review ..S AQAOA=0 F S AQAOA=$O(^AQAOC(AQAOIFN,"IADDRV",AQAOA)) Q:AQAOA'=+AQAOA D ...S AQAOREF=$P(^AQAOC(AQAOIFN,"IADDRV",AQAOA,0),U) Q:AQAOREF="" ...S AQAOIFN=AQAOIFN_"-"_AQAOA D REFSET^AQAOCHK0 S AQAOIFN=$P(AQAOIFN,"-") .I AQAOLST>0 D ;find additonal referrals off review ..S AQAOA=0 F S AQAOA=$O(^AQAOC(AQAOIFN,"REV",AQAOLST,"ADDRV",AQAOA)) Q:AQAOA'=+AQAOA D ...S AQAOREF=$P(^AQAOC(AQAOIFN,"REV",AQAOLST,"ADDRV",AQAOA,0),U) ...Q:AQAOREF="" ...S AQAOIFN=AQAOIFN_"-"_AQAOA D REFSET^AQAOCHK0 S AQAOIFN=$P(AQAOIFN,"-") ; ; ACTION ; >>> find any pending action plans user needs to review F I=1:1:5 S AQAOPLN=0 D .F S AQAOPLN=$O(^AQAO(5,"AC",I,AQAOPLN)) Q:AQAOPLN="" D ..Q:'$D(^AQAO(5,AQAOPLN,0)) S AQAOSTR=^(0),AQAOIND=$P(AQAOSTR,U,14) ..Q:$P(^AQAO(5,AQAOPLN,0),U,12)'=DUZ(2) ;PATCH 3 ..I '($D(AQAOXYZ)#2),AQAOIND]"" Q:'$D(AQAOXYZ(2,AQAOIND)) ;not usr ind ..I (I=2),($P(AQAOSTR,U,4)]""),($P(AQAOSTR,U,4)>> go to print rtn ;if no occ needing review found; quit rtn I '$D(AQAOXYZ(3)) W !!,"*** NONE FOUND ***" G END^AQAOCHK2 G ^AQAOCHK1 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 AQAOCHK4 AQAOCHK4 ; IHS/ORDC/LJF - PRINT TICKLER REPORT ; [ 05/10/95 3:08 PM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn is called by ^AQAOCHK2 to print each occurrence with its ;case ID, patient, indicator, ward/service and more. ; PRINT ;ENTRY POINT >>> print selected range of items ;called by AQAOCHK2 D INIT^AQAOUTIL S AQAOHCON="Patient",AQAOTY="OCCURRENCE TICKLER REPORT" D HEADING^AQAOUTIL D HDG1 F AQAOI=1:1 S AQAOX=$P(AQAOXYZ(4),",",AQAOI) Q:AQAOX="" Q:AQAOSTOP=U D .I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 .W !!,$P($T(MSG+AQAOX),";;",3),":" ;print section heading .S AQAOIND=0 .F S AQAOIND=$O(^TMP("AQAOCHK",$J,AQAOX,AQAOIND)) Q:AQAOIND="" Q:AQAOSTOP=U D ..S AQAODT=0 ..F S AQAODT=$O(^TMP("AQAOCHK",$J,AQAOX,AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D ...S AQAOIFN=0 ...F S AQAOIFN=$O(^TMP("AQAOCHK",$J,AQAOX,AQAOIND,AQAODT,AQAOIFN)) Q:AQAOIFN="" Q:AQAOSTOP=U D ....I $D(AQAOALL),(AQAOX=2)!(AQAOX=3) D ALLREF Q ;print all referrals ....S AQAOSTR=$G(^TMP("AQAOCHK",$J,AQAOX,AQAOIND,AQAODT,AQAOIFN)) ;PATCH 3 ....I AQAOX=5 D PRINTA Q ;action plan item ....Q:AQAOSTR="" ;PATCH 3 ....I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 ....W !,"#",$P(^AQAOC(+AQAOIFN,0),U) ;case id # ....I AQAOX<4 W $$OVERDUE^AQAOCHK0 ;print * if overdue for review ....S Y=AQAODT X ^DD("DD") W ?10,Y ;occ date ....S X=$P(^AQAOC(+AQAOIFN,0),U,2) ....W:X]"" ?23,$J($P(^AUPNPAT(X,41,DUZ(2),0),U,2),6) ;chart # ....W ?32,$P(^AQAO(2,AQAOIND,0),U) ;indicator # ....I AQAOX=1 D Q ;no other print items for initial reviews .....W:$P(^AQAOC(+AQAOIFN,0),U,11)=1 ?43,"AUTOMATED ENTRY" W ?60 .....S X=$P(^AQAOC(+AQAOIFN,0),U,6) I X]"" W $P($G(^SC(X,0)),U,2),"/" .....S X=$P(^AQAOC(+AQAOIFN,0),U,7) I X]"" W $P($G(^DIC(49,X,0)),U,2) ....I AQAOX=4 D Q ;reviewed, not closed occ .....W ?43,"Last review: ",$E($P(^AQAO(7,$P(AQAOSTR,U,2),0),U),1,4) .....S X=$P(AQAOSTR,U,3) W:X]"" ?62,"Action: ",$P(^AQAO(6,X,0),U,2) ....;print referred by for aqax=2 or 3 ....S Y=$P(AQAOSTR,U,2),C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ ....W ?43,"Referred by: ",$E(Y,1,23) ....S Y=$P(AQAOSTR,U,3),C=$P(^DD(9002167,.19,0),U,2) D Y^DIQ ....W !?43,"Referred to: ",$E(Y,1,23) I '($D(AQAOXYZ)#2) D .I $Y>(IOSL-9) D NEWPG^AQAOUTIL D HDG1 .W !!,">>To find Occurrence Data Entry options, follow this path:" .W !?5,"D for Data Collection Menu;" .W !?10,"ODE for Occurrence Data Entry Menu;" .W !?15,"And then POW for Print Occurrence Worksheets;" .W !?21,"Or OCC for Enter/Edit Occurrence Record;" .W !?21,"Or PRW for Print Review Worksheets;" .W !?21,"Or REV for Enter/Edit Occurrence Review." I '$D(ZTQUEUED),IOST["C-" D PRTOPT^AQAOVAR ; ; END ;ENTRY POINT called by AQAOCHK1 K ^TMP("AQAOCHK",$J) K AQAOXYZ D ^%ZISC D KILL^AQAOUTIL Q ; ; ALLREF ; >> SUBRTN to print all referrals for qi staff user Q:'$D(^TMP("AQAOCHK",$J,AQAOX,AQAOIND,AQAODT,AQAOIFN,1)) S AQAOSTR=^(1) I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 W !,"#",$P(^AQAOC(+AQAOIFN,0),U) ;case id # I AQAOX<4 W $$OVERDUE^AQAOCHK0 ;print * if overdue for review S Y=AQAODT X ^DD("DD") W ?10,Y ;occ date W ?23,"Indicator: ",$P(^AQAO(2,AQAOIND,0),U) ;indicator # S Y=$P(AQAOSTR,U,2),C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ W ?43,"Referred by: ",$E(Y,1,23) S Y=$P(AQAOSTR,U,3),C=$P(^DD(9002167,.19,0),U,2) D Y^DIQ W !?43,"Referred to: ",$E(Y,1,23) Q ; ; PRINTA ; >> SUBRTN to print action plan items I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 W !,"#",$P(^AQAO(5,+AQAOIFN,0),U) ;action plan # W ?12,"Indicator: ",$P(^AQAO(2,AQAOIND,0),U) ;indicator # S Y=AQAODT,C=$P(^DD(9002168.5,.05,0),U,2) D Y^DIQ W ?32,$E(Y,1,25) ;status S X=$P(^AQAO(5,+AQAOIFN,0),U,2) W:X]"" ?60,"ACTION TYPE: ",$P(^AQAO(6,X,0),U,2) ;action type Q ; ; HDG1 ; >> SUBRTN to print 2nd half of heading W ?22,"(Occurrences & Action Plans Pending)" W !?20,"[""*"" after Case ID means overdue for review]",!,AQAOLINE W !,"Case ID",?10,"Occ Date",?23,"Chart #",?32,"Indicator",!,AQAOLIN2,! Q ; ; MSG ;; ;; Occurrence(s) needing INITIAL REVIEWS;;INITIAL REVIEWS ;; Occurrence(s) with PERSONAL REFERRALS;;PERSONAL REFERRALS ;; Occurrence(s) with REFERRALS TO QI TEAM;;TEAM REFERRALS ;; Occurrence(s) REVIEWED but NOT CLOSED;;OPEN OCCURRENCES ;; Pending ACTION PLAN(S);;ACTION PLANS 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 AQAOEDTS AQAOEDTS ; IHS/ORDC/LJF - MULTIPLE FIELDS EDITS ; [ 05/10/95 3:42 PM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn is called by various data entry rtns to handle file-driven ;user interface for the section defined before this call. ; OPT ; >>> get data entry option from review type Q:'$D(^AQAQX(AQAOPT,0)) ;bad pointer in review type file ; ; >>> for each review, choose multiples to enter/edit LOOP ; >>> find all screens available to work on & put in proper order S AQAOSC=0 ;screen's entry # in multiple F S AQAOSC=$O(^AQAQX(AQAOPT,"PG","B",AQAOSC)) Q:AQAOSC="" D .S AQAOSN=0 ;screen's order # .F S AQAOSN=$O(^AQAQX(AQAOPT,"PG","B",AQAOSC,AQAOSN)) Q:AQAOSN="" D ..Q:'$D(^AQAQX(AQAOPT,"PG",AQAOSN,0)) ..S AQAOPTL=$P(^AQAQX(AQAOPT,"PG",AQAOSN,0),U,3) ;screen title ..S AQAOP(AQAOSC)=AQAOPTL_U_AQAOSN ;array with screens in order ..Q ; ; >>> loop thru array for each screen and allow user to edit S AQAOSC=0,X="" K DUOUT ;PATCH 3 F S AQAOSC=$O(AQAOP(AQAOSC)) Q:AQAOSC="" Q:$D(DUOUT) Q:X=U D .S AQAOPTL=$P(AQAOP(AQAOSC),U),AQAOSN=$P(AQAOP(AQAOSC),U,2) .K DIR S Y=$P(^AQAQX(AQAOPT,"PG",AQAOSN,0),U,2) .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 AQAOSTR=$G(^AQAQX(AQAOPT,"PG",AQAOSN,1)) .I ($P(AQAOSTR,U)'="") D MULTFIND Q ;multiple entries in linked file .D ITEMFIND Q ;multiple fields in occ file ; END Q ; ; ITEMFIND ; >> SUBRTN to find each items on screen and display them by number<< ; ; >>> find items for this screen K AQAOA S AQAOTM=0 W !!!,"<<",AQAOPTL,">>",! F S AQAOTM=$O(^AQAQX(AQAOPT,"PG",AQAOSN,"IT","B",AQAOTM)) Q:AQAOTM'=+AQAOTM D .S AQAOTMN=0 .F S AQAOTMN=$O(^AQAQX(AQAOPT,"PG",AQAOSN,"IT","B",AQAOTM,AQAOTMN)) Q:AQAOTMN="" D ..Q:'$D(^AQAQX(AQAOPT,"PG",AQAOSN,"IT",AQAOTMN,0)) S AQAOMFL=^(0) ..; ..; >>> print items in order with contents and save field # in array ..S AQAOFLD=$P(AQAOMFL,U,2) ..W !,$J(+AQAOMFL,2),") ",$P(^DD(9002167,AQAOFLD,0),U) ;# & descrpt ..K ^UTILITY("DIQ1",$J) K DIQ,DR ..S (DIC,AQAOFL)=9002167,DA=AQAOIFN,DR=AQAOFLD D EN^DIQ1 ..I $D(^UTILITY("DIQ1",$J,AQAOFL,DA,AQAOFLD)) W ?45,^(AQAOFLD) ..K ^UTILITY("DIQ1",$J) ..S AQAOA(+AQAOMFL)=AQAOFLD ;set array with # and field ; ; >>> choose items to edit and edit via ^die S (AQAOTM,AQAOXX)=0 W ! F S AQAOXX=$O(AQAOA(AQAOXX)) Q:AQAOXX="" S AQAOTM=AQAOXX S DIR("?")="Choose option from list above" S DIR(0)="LO^0:"_AQAOTM_"^K:X#1 X" D ^DIR Q:$D(DIRUT) Q:Y=-1 S DR="" I +Y=0 F S X=$O(AQAOA(X)) Q:X="" D ;user chose all .I AQAOA(X)[U S DR(2,$P(AQAOA(X),U,2))=$P(AQAOA(X),U,3) .S DR=DR_";"_$P(AQAOA(X),U) E F S X=$P(Y,",") Q:X="" D ;user chose range by number .I AQAOA(X)[U S DR(2,$P(AQAOA(X),U,3))=$P(AQAOA(X),U,2) .S X=$P(AQAOA(X),U),DR=DR_";"_X .S Y=$P(Y,",",2,99) I DR?1";".E S DR=$E(DR,2,99) K DIE S DIE=9002167,DA=AQAOIFN D ^DIE ; S AQAODIR=DIR("A") K DIR S DIR(0)="Y",DIR("B")="NO" S DIR("A")="Do you wish to EDIT this category again" D ^DIR K DIR I Y=1 S AQAOTM=0,DIR("A")=AQAODIR K AQAODIR W !! G ITEMFIND Q ; >>end of ITEMFIND subrtn<< ; ; ; MULTFIND ; >>SUBRTN to display multiple entries in linked files<< ; >>> set variables about linked file S AQAOFL=$P(AQAOSTR,U),AQAOFLD=$P(AQAOSTR,U,2) ;file#, fields to edit S AQAOGBL=^DIC(AQAOFL,0,"GL") ;global node for file S AQAOXX=0,AQAOXY=AQAOGBL_"""AB"",AQAOIFN,AQAOXX)" ;set global xref ; S AQAOQUIT=0 W !!!,"<<",AQAOPTL,">>",! ;print screen heading S X=$G(^AQAQX(AQAOPT,"PG",AQAOSN,2)) I X]"" X X ;special rtn for screen I AQAOQUIT=1 Q ;special rtn found cause to quit edit of this screen ; ; >>> loop thru entries in linked file and display them by # S (AQAOXX,AQAOCNT)=0 F S AQAOXX=$O(@AQAOXY) Q:AQAOXX'=+AQAOXX D .S AQAOTM=$P(@(AQAOGBL_"AQAOXX,0)"),U) ;.01 field of linked file .S AQAOCNT=AQAOCNT+1,AQAOA(AQAOCNT)=AQAOXX .S Y=AQAOTM,C=$P(^DD(AQAOFL,.01,0),U,2) D Y^DIQ .W !,AQAOCNT,") ",Y .S X=$G(^AQAQX(AQAOPT,"PG",AQAOSN,4)) I X["" X X ;identifier code .Q ; ; >>> last number is choice to add new entry I AQAOCNT=0 D ADD G MULTFIND:$O(@AQAOXY) Q S AQAOCNT=AQAOCNT+1 W !,AQAOCNT,") ADD NEW ENTRY" ; CHOOSE ; >>> choose item(s) to edit W ! S DIR(0)="NO^1:"_AQAOCNT,DIR("?")="Choose from list above" D ^DIR Q:X="" Q:$D(DIRUT) G CHOOSE:Y=-1 I (+Y=AQAOCNT) D ADD G MULTFIND E S DA=AQAOA(+Y) D EDIT G MULTFIND ; ADD ;add new entry to subfile or edit entries already there K DIC S DIE="^AQAOC(",DLAYGO=AQAOFL,DA=AQAOIFN S DR=AQAOFLD_" ADD]" D ^DIE W ! Q ; EDIT ; >>> edit entries K DIC,DIE S DIE=AQAOGBL,DIDEL=AQAOFL S DR=AQAOFLD_" EDIT]" D ^DIE W ! Q ; ; >>end of MULTFIND subrtn<< AQAOENTR AQAOENTR ; IHS/ORDC/LJF - ENTER OR EDIT AN OCCURRENCE ; [ 05/10/95 3:29 PM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This is the main rtn for occurrence data entry. It is used for ;adding new occurrences, editing occ data and initial reviews, and ;creating occurrences from visit-based search templates. ; CHOOSE ; >>> choose add new occurrence or edit open one I $D(AQAOIFN) L -^AQAOC(AQAOIFN) K AQAOIFN ;unlock previous occ D INTRO^AQAOHOCC ;intro text for option K DIR S DIR(0)="SO^A:ADD NEW OCCURRENCE;C:CREATE ENTRIES FROM SEARCH TEMPLATE;E:EDIT EXISTING OCCURRENCE" S DIR("A")="Choose the ACTION you wish to perform" D ^DIR G EXIT:X="",EXIT:$D(DIRUT),CHOOSE:Y=-1 ; ; >>> use proper lookup then edit occurrence data I Y="C" D ^AQAOENTS G CHOOSE ;separate code for occ from searches ; ;if for edit, get occ, drop to visit I Y="E" D G EXIT:'$D(AQAOIFN),CHOOSE:$D(DUOUT),EXIT:$D(DTOUT) .D ASK^AQAOLKP ; ;add new one, drop to visit line E D ADD^AQAOLKP G EXIT:'$D(AQAOIFN),CHOOSE:$D(DUOUT),EXIT:$D(DTOUT) ; ; VISIT ; >>> look up and add patient's visit L +^AQAOC(AQAOIFN):1 I '$T D G CHOOSE ;lock occ .W !!,"CANNOT EDIT; ANOTHER USER IS EDITING THIS OCCURRENCE.",! L +^AQAGU(0):1 I '$T D G CHOOSE ;lock audit file .W !!,"CANNOT EDIT OCCURRENCE; AUDIT FILE LOCKED. TRY AGAIN.",! S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="E" S AQAOUDIT("COMMENT")="EDIT OCCURRENCE" D ^AQAOAUD ;record transact ; W ! S AQAOVSIT=$P($G(^AQAO(2,$P(^AQAOC(AQAOIFN,0),U,8),1)),U,2) G EDIT:AQAOVSIT'="Y" ;not visit related G EDIT:$P(^AQAOC(AQAOIFN,0),U,3)'="" ;visit already in occurrence D VISIT^AQAOHOCC ;help text on visit W !! K DIR S DIR(0)="D^::EX",DIR("?")="^D VHELP^AQAOHOCC" ;PATCH 3 S DIR("A")="Enter VISIT DATE" D ^DIR G EDIT:Y=U I Y<0 W *7,"??" G EDIT ;PATCH 3 S APCDVLDT=Y ;date sent to pcc lookup rtn for visit ifn ;set APCDOVRR to override screen that dep entry count must be >1 S APCDPAT=AQAOPAT,(APCDOVRR,APCDLOOK,APCDVSIT)="" D ^APCDVLK K APCDOVRR,APCDLOOK ;visit lookup needs only date G EDIT:X=U I APCDVSIT="" W *7,"??" G EDIT ;PATCH 3 S AQAOSTR=$G(^AUPNVSIT(APCDVSIT,0)) S DIE="^AQAOC(",DA=AQAOIFN S DR=".03////"_APCDVSIT D ^DIE ;stuff vsit K APCDCAT,APCDCLN,APCDDATE,APCDLOC,APCDPAT,APCDTYPE,APCDVSIT,APCDVLDT ; ; EDIT ; >>> edit basic occurrence data ; >> find review type entered then loop thru fields S AQAOIND=$P(^AQAOC(AQAOIFN,0),U,8) G ASKREVU:AQAOIND="" ;ind ifn S AQAORT=$P($G(^AQAO(2,AQAOIND,1)),U) G ASKREVU:AQAORT="" ;revtyp ifn S AQAOPT=$P(^AQAO(3,AQAORT,0),U,3) G ASKREVU:AQAOPT="" ;driver ifn D ^AQAOEDTS ;data entry driver ; ; >> edit case summary field W !! D CSUM^AQAOHOCC S DIE="^AQAOC(",DA=AQAOIFN,DR="2" D ^DIE I $D(Y) G CHOOSE ;user entered "^" ; ; ASKREVU ; >>> ask to begin review process ; ; if rate-based, stuff review then continue I $P(^AQAO(2,AQAOIND,0),U,4)="R",$P(^(1),U,4)]"",$P(^(1),U,5)]"",$P(^(1),U,6)]"",$P(^AQAOC(AQAOIFN,1),U,6)="" D G CLOSE .L +^AQAGU(0):1 I '$T D G CHOOSE ..W !!,"CANNOT ENTER REVIEW; AUDIT FILE LOCKED. TRY AGAIN.",! .S AQAOUDIT("COMMENT")="REVIEW STUFFED",AQAOUDIT("DA")=AQAOIFN .S AQAOUDIT("ACTION")="E" D ^AQAOAUD ;audit review .W !! K DIR S DA=AQAOIFN,DIE="^AQAOC(",DR="[AQAO RATE REVIEW]" D ^DIE .W !!,"Initial Review Recorded. . ." ; ; otherwise ask if user wants to enter initial review W !! K DIR S DIR(0)="Y",DIR("B")="NO" S DIR("A")="DO YOU WISH TO START REVIEW PROCESS FOR THIS ENTRY" D ^DIR G EXIT:$D(DIRUT) I Y=0 W @IOF G CHOOSE ; I $P($G(^AQAOC(AQAOIFN,1)),U,6)]"" D I Y'=1 G CLOSE .W !!,*7,"INITIAL REVIEW already performed!" .K DIR S DIR(0)="Y",DIR("B")="NO" .S DIR("A")="Do you wish to edit this INITIAL REVIEW" D ^DIR ; INITIAL ; >>> enter initial review data L +^AQAGU(0):1 I '$T D G CHOOSE .W !!,"CANNOT ENTER REVIEW; AUDIT FILE LOCKED. TRY AGAIN.",! S AQAOUDIT("COMMENT")="INITIAL REVIEW",AQAOUDIT("DA")=AQAOIFN S AQAOUDIT("ACTION")="E" D ^AQAOAUD ;audit review W !! K DIR S DA=AQAOIFN,DIE="^AQAOC(",DR="[AQAO FIRST REVIEW]" D ^DIE ; ;if initial action is practitioner-based, flag providers S AQAOACT=$P(^AQAOC(AQAOIFN,1),U,6) ;initial action I AQAOACT]"",$P(^AQAO(6,AQAOACT,0),U,4)=2 D ;practitioner-based .S AQAOPT=$O(^AQAQX("B","AQAO PROV ACTION",0)) Q:AQAOPT="" .K AQAOP D ^AQAOEDTS ;call driver ; W !!,"INITIAL REVIEW COMPLETE . . ." H 2 ; CLOSE ;if user has close out key AND initial action not referral AND ;no other reviews exist for occ THEN user has chance to close out occ I $D(^XUSEC("AQAOZCLS",DUZ)),$P(^AQAOC(AQAOIFN,1),U,6)]"",$P(^AQAO(6,$P(^AQAOC(AQAOIFN,1),U,6),0),U,4)'=1,'$O(^AQAOC(AQAOIFN,"REV",0)) D .S AQAOENTR="" D CLOSE^AQAOVAL K AQAOENTR ; ; G CHOOSE ; ; EXIT ; >>> eoj I $D(AQAOIFN) L -^AQAOC(AQAOIFN) D KILL^AQAOUTIL Q ; ; ERROR ; >>> SUBRTN to print error msg W !!,*7,"COULD NOT ADD OCCURRENCE TO FILE! PLEASE SEE SITE MANAGER!" W !! G EXIT 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 ; [ 05/08/95 12:08 PM ] ;;1;QAI MANAGEMENT;**2,3**;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,(Y0: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) ; ; ENHANCE(N) ;EP; EXTRN FUNC to test whether enhancement #N installed;PATCH 3 ; -- checks on existence of help frame NEW X S X="AQAZ ENHANCE "_N Q $S($D(^DIC(9.2,"B",X)):1,1:0) AQAOPC11 AQAOPC11 ; IHS/ORDC/LJF - CALCULATE OCC BY IND ; [ 05/12/95 8:19 AM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn contains the code to find the occ by indicator & date range ;and find criteria values. ; K ^TMP("AQAOPC1",$J) K ^TMP("AQAOPC11",$J) S AQAOCNT=0 ;initialize total count DTLOOP ; >>> loop thru occ file by date for indicator S AQAODT=AQAOBD-.0001,AQAOEDT=AQAOED_.2400 F S AQAODT=$O(^AQAOC("AA",AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAODT>AQAOEDT 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 ...Q:'$D(^AQAOC(AQAOIFN,0)) S AQAOSTR=^(0) Q:$P(^(1),U)=2 ;deleted ...Q:$P(^AQAOC(AQAOIFN,0),U,9)'=DUZ(2) ;PATCH 3 ...Q:$$EXCEP^AQAOLKP(AQAOIFN) ;exception to criteria? ...I $D(AQAOXSN) Q:$$CHK^AQAOPCX(AQAOXSN)=0 ;flag for special searches ...; ;also returns AQAOARS arry ...S AQAOCNT=AQAOCNT+1 ;increment occ total ...; ...; >> loop thru criteria values for occurrence ...S AQAOCRT=0 ...F S AQAOCRT=$O(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT)) Q:AQAOCRT="" D ....Q:'$D(AQAOCR(AQAOCRT)) ;criteria not chosen for report ....S AQAOT=$P($G(^AQAO1(6,AQAOCRT,0)),U,2) ;set crit type ....S AQAOC=0 ....F S AQAOC=$O(^AQAOCC(5,"AC",AQAOIFN,AQAOCRT,AQAOC)) Q:AQAOC="" D .....D SET ;set ^tmp and increment totals ; NEXT ; >>> go to print rtn G ^AQAOPC12 ; ; SET ; >> SUBRTN to set ^tmp & increment totals I AQAOT="" S AQAOVAL="" G SET1 ;no value S AQAOVAL=$P(^AQAOCC(5,AQAOC,0),U,AQAOT+4) ;crit value S AQAOVALP="" I AQAOVAL="" G SET1 ;no value set, skip counts I AQAOT=2 S AQAOVALP=$P($G(^AQAO1(4,AQAOVAL,0)),U,2) S X=$S(AQAOT=1:.05,AQAOT=2:.06,AQAOT=3:.07,1:.08),Y=AQAOVAL I X=.08 S AQAOVAL=$E(Y,4,5)_" "_$E(Y,6,7)_" "_$E(Y,2,3) E S C=$P(^DD(9002166.5,X,0),U,2) D Y^DIQ S AQAOVAL=Y ;printable form COMMAS I AQAOVAL["," S AQAOVAL=$P(AQAOVAL,",")_" "_$P(AQAOVAL,",",2,99) G COMMAS ; SET1 S AQAOSUB=0 I '$D(AQAOXSN) D SET2 Q F S AQAOSUB=$O(AQAOARS(AQAOSUB)) Q:AQAOSUB="" D SET2 Q ; ; SET2 ; >> SUBRTN to increment counts I (AQAOT'=2),(AQAOVAL]"") D ;increment value cnt .S ^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVAL)=$G(^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVAL))+1 I (AQAOT=2),(AQAOVALP]"") D ;increment value counts for set of codes .S ^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVALP)=$G(^TMP("AQAOPC11",$J,AQAOSUB,AQAOCRT,AQAOVALP))+1 I '$D(^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)) D .S ^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)=$P(AQAOSTR,U)_U_AQAOCRT_U_AQAOVAL E S ^TMP("AQAOPC1",$J,AQAOSUB,AQAODT,AQAOIFN)=^(AQAOIFN)_U_AQAOCRT_U_AQAOVAL Q AQAOPC51 AQAOPC51 ; IHS/ORDC/LJF - CALC FOR QTR PROGRESS RPT ; [ 05/09/95 9:15 AM ] ;;1;QAI MANAGEMENT;**2,E1**;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","DIMENSION" D ;PATCH 2;ENH1 .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)> 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 AQAOPC72 AQAOPC72 ; IHS/ORDC/LJF - PRINT SINGLE CRIT REPORT ; [ 05/12/95 7:41 AM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This routine contains the code to print the report of criterion ;values by month for a particular indicator. ; ; >> initialize variables D MONTHS ;set array for all months included in report ;use wide margin if date range 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 X=$O(AQAOCR(0)),AQAOTY="CRITERION: "_AQAOCR(X) ;S AQAOTY=$E(AQAOTY,1,59) S AQAOTY="TRENDS BY MONTH FOR A CRITERION" 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 AQAOM=$$INDNAME ;set indicator heading I AQAOPAGE=0 D HEADING^AQAOUTIL I AQAOTYPE="L" D HDG2 I '$D(AQAOCNT) D G EXIT .W !?10,">> NO OCCURRENCES FOUND FOR THIS INDICATOR <<" I AQAOTYPE="L" D G EXIT:AQAOSTOP=U D NEWPG^AQAOUTIL G EXIT:AQAOSTOP=U .D LIST D HDG3,COUNTP ;print counts by month ; ; 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("AQAOPC7",$J),^TMP("AQAOPC7A",$J),^TMP("AQAOPC7B",$J) K ^UTILITY("DIQ1",$J) Q ; ; LIST ; >> SUBRTN to list occurrences S AQAOSUB=0 I '$D(AQAOXSN) D PRINT Q F S AQAOSUB=$O(^TMP("AQAOPC7A",$J,AQAOSUB)) Q:AQAOSUB="" Q:AQAOSTOP=U D .W !!?AQAOIOMX-$L(AQAOSUB)\2,AQAOSUB,! D PRINT Q ; PRINT ; >> SUBRTN to print each occurrence S AQAODT=0 F S AQAODT=$O(^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D .S AQAOID=0 .F S AQAOID=$O(^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT,AQAOID)) Q:AQAOID="" Q:AQAOSTOP=U D ..I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG2 ..S X=^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT,AQAOID) ..W !,AQAOID S Y=AQAODT X ^DD("DD") W ?10,Y ..W ?25,$P(X,U),?35,$P(X,U,2),?45,$P(X,U,3) Q ; ; COUNTP ; >> SUBRTN to to loop thru extra sort then print line S AQAOSUB=0 I '$D(AQAOXSN) D VALUES Q F S AQAOSUB=$O(^TMP("AQAOPC7",$J,AQAOSUB)) Q:AQAOSUB="" Q:AQAOSTOP=U D .W !!?AQAOIOMX-$L(AQAOSUB)\2,AQAOSUB,! D VALUES Q ; VALUES ; >> SUBRTN to print criteria values by month D MONTHS ;set array for all months included in report S AQAOVAL=0 F S AQAOVAL=$O(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL)) Q:AQAOVAL="" Q:AQAOSTOP=U D .S AQAOSUBT=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL) ;value subtl .I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG3 .W !!,AQAOVAL,?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("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON)) D Q ...S X=$X+9 W ?X ..S X=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON) ..W ?($X+1),$J(X,8) ; print count for month ..S AQAOARM(AQAOMON)=AQAOARM(AQAOMON)+X ;increment total .W ?AQAOIOMX-11,$J(AQAOSUBT,8) .I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG3 .; .;fill in percentages for all months for this criterion value .W !?8 S AQAOMON=0 .F S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON="" Q:AQAOSTOP=U D ..I '$D(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON)) D Q ...S X=$X+9 W ?X ..S X=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON) ..S X=(X/^TMP("AQAOPC7B",$J,AQAOSUB,AQAOMON)*100)_"%" ..W ?($X+1),$J(X,8,2) ; print % for month .W ?AQAOIOMX-10,$J(AQAOSUBT/AQAOCNT(AQAOSUB)*100,8,2),"%" Q:AQAOSTOP=U ; ; ;print monthly totals for this indicator I $Y>(IOSL-4) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG3 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(+$G(AQAOCNT(AQAOSUB)),8),! ;PATCH 3 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 for listing W ?AQAOIOMX-$L(AQAORNG)/2,AQAORNG,! W ?AQAOIOMX-$L(AQAOM)/2,AQAOM,!,AQAOLIN2,! S X=$O(AQAOCR(0)) W ?3,"CRITERION: "_AQAOCR(X) W !,"Case ID",?10,"Occ Date",?25,"Age",?35,"Sex",?45,"Value" W !,AQAOLINE Q ; HDG3 ; >> SUBRTN to print 2nd half of heading for stats pages W ?AQAOIOMX-$L(AQAORNG)/2,AQAORNG,! W ?AQAOIOMX-$L(AQAOM)/2,AQAOM,!,AQAOLIN2,! S X=$O(AQAOCR(0)) W ?3,"CRITERION: "_AQAOCR(X) W !,"Values " S X=0 F S X=$O(AQAOARM(X)) Q:X="" W ?($X+2),$E(X,4,5),"/",1700+$E(X,1,3) W ?AQAOIOMX-9," Totals",!,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 AQAOPC73 AQAOPC73 ; IHS/ORDC/LJF - PRINT SINGLE CRIT RPRT-ASCII ; [ 05/23/95 10:51 AM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This routine prints the single criterion report in ASCII format ;using the delimiter the user has chosen. ; ; >> 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 X=$O(AQAOCR(0)),AQAOTY="TRENDS BY CRITERIA: "_AQAOCR(X) ;PATCH 3 ;S AQAOTY=$E(AQAOTY,1,60) ;PATCH 3 S AQAOTY="TRENDS BY MONTH FOR A CRITERION" ;PATCH 3 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 AQAOM=$$INDNAME ;set indicator heading D DLMHDG^AQAOUTIL,HDG2 I '$D(AQAOCNT) W !,">> NO OCCURRENCES FOUND FOR THIS INDICATOR <<" Q ;PATCH 3 I AQAOTYPE="L" D LIST D HDG3,COUNTP ;print counts by month ; ; EXIT ; >>> eoj W !!,*7,"*** STOP CAPTURE NOW ***" I IOST["C-" D PRTOPT^AQAOVAR I $D(AQAOIOM),IOT'="HFS" S X=AQAOIOM X ^%ZOSF("RM") D ^%ZISC D KILL^AQAOUTIL K ^TMP("AQAOPC7",$J),^TMP("AQAOPC7A",$J),^UTILITY("DIQ1",$J) K ^TMP("AQAOPC7B",$J) ;PATCH 3 Q ; LIST ; >> SUBRTN to list occurrences S AQAOSUB=0 I '$D(AQAOXSN) D PRINT Q F S AQAOSUB=$O(^TMP("AQAOPC7A",$J,AQAOSUB)) Q:AQAOSUB="" D .W !!?AQAOIOMX-$L(AQAOSUB)\2,AQAOSUB,! D PRINT Q ; PRINT ; >> SUBRTN to print each occurrence S AQAODT=0 F S AQAODT=$O(^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT)) Q:AQAODT="" D .S AQAOID=0 .F S AQAOID=$O(^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT,AQAOID)) Q:AQAOID="" D ..S X=^TMP("AQAOPC7A",$J,AQAOSUB,AQAODT,AQAOID) ..S Y=AQAODT X ^DD("DD") ;PATCH 3 ..S X(",")=" ",Y=$$REPLACE^XLFSTR(Y,.X) ;PATCH 3 ..W !,AQAOID,AQAODLM,Y,AQAODLM,$P(X,U) ;PATCH 3 ..W AQAODLM,$P(X,U,2),AQAODLM,$P(X,U,3) Q ; ; COUNTP ; >> SUBRTN to to loop thru extra sort then print line S AQAOSUB=0 I '$D(AQAOXSN) D VALUES Q F S AQAOSUB=$O(^TMP("AQAOPC7",$J,AQAOSUB)) Q:AQAOSUB="" D .W !!,AQAOSUB,! D VALUES Q ; VALUES ; >> SUBRTN to print criteria values by month D MONTHS ;PATCH 3 S AQAOVAL=0 F S AQAOVAL=$O(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL)) Q:AQAOVAL="" D .S AQAOSUBT=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL) ;value subtl .W !,AQAOVAL .; .;fill in counts for all months .S AQAOMON=0 .F S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON="" D ..W AQAODLM ..I '$D(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON)) Q ..S X=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON) ;cnt 4 month;PATCH 3 ..W X ;PATCH 3 ..S AQAOARM(AQAOMON)=AQAOARM(AQAOMON)+X ;increment total .W AQAODLM,AQAOSUBT .; .;fill in percentages for all months for this criterion value .;W !,AQAODLM,(AQAOSUBT/AQAOCNT*100),"%" ;value as % of total;PATCH 3 .W !,AQAODLM S AQAOMON=0 ;PATCH 3 .F S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON="" D ;PATCH 3 ..I '$D(^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON)) W AQAODLM Q ;PATCH 3 ..S X=^TMP("AQAOPC7",$J,AQAOSUB,AQAOVAL,AQAOMON) ;PATCH 3 ..W $J((X/^TMP("AQAOPC7B",$J,AQAOSUB,AQAOMON)*100),8,2),"%" ;PATCH 3 ..W AQAODLM .W $J((AQAOSUBT/AQAOCNT(AQAOSUB)*100),8,2),"%" ;PATCH 3 ; ;print monthly totals for this indicator W !,AQAOLIN3,!,"Monthly:" S AQAOMON=0 F S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON="" D .W AQAODLM,AQAOARM(AQAOMON) ;# of occ by month W AQAODLM,+AQAOCNT(AQAOSUB) ;PATCH 3 ; ;print % for each month for ind ;S AQAOMON=0 W ! ;PATCH 3 ;F S AQAOMON=$O(AQAOARM(AQAOMON)) Q:AQAOMON="" D ;PATCH 3 ;.W AQAODLM ;PATCH 3 ;.W:AQAOCNT>0 (AQAOARM(AQAOMON)/AQAOCNT*100),"%" ;% of occ;PATCH 3 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 for listing W !,AQAORNG,!,AQAOM,!,AQAOLIN2 ;PATCH 3 W !,"Case ID",AQAODLM,"Occ Date",AQAODLM,"Age",AQAODLM W "Sex",AQAODLM,"Value",!! Q ; HDG3 ; >> SUBRTN to print 2nd half of heading for stats section W !,AQAORNG,!,AQAOM,!!,"Values " ;PATCH 3 S X=0 F S X=$O(AQAOARM(X)) Q:X="" W AQAODLM,1700+$E(X,1,3),"/",$E(X,4,5) W AQAODLM," Totals",! 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 Q AQAOM AQAOPR71 AQAOPR71 ; IHS/ORDC/LJF - CALCULATE REVIEWED OCC RPRT ; [ 05/08/95 3:50 PM ] ;;1;QAI MANAGEMENT;**3,E1**;AUG 15, 1994 ; ;This rtn finds all appropriate occurrences based on indicators ;selected and date range. ; K ^TMP("AQAOPR7A",$J) S AQAOCNT=0 ;initialize total count TMP ; >>> loop thru ^TMP to find indicators F AQAOI="SINGLE","MED STAFF F","FACILITY WIDE","KEY FUNCTION","DIMENSION","OTHER" D ;PATCH 3;ENH1 .S AQAOF=AQAOI .F S AQAOF=$O(^TMP("AQAOPR7",$J,1,AQAOF)) Q:AQAOF'[AQAOI D ..S AQAOIND=0 ..F S AQAOIND=$O(^TMP("AQAOPR7",$J,1,AQAOF,AQAOIND)) Q:AQAOIND="" D ...; ...; >>for this indicator, find occ for date range ...S AQAODT=AQAOBD-.0001,AQAOEDT=AQAOED_.2400 ...F S AQAODT=$O(^AQAOC("AA",AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAODT>AQAOEDT 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 ......Q:'$$STATUS ;wrong case status ......Q:'$$USERTEAM ;at least one rev/ref has one of selected user/team ......S AQAOCNT=AQAOCNT+1 ;increment total cases ......S X=$P(^AQAO(2,AQAOIND,0),U)_" "_$P(^(0),U,2) ;ind # & name ......S ^TMP("AQAOPR7A",$J,X,AQAODT,AQAOIFN)="" ; NEXT ; >>> go to print rtn G ^AQAOPR72 ; ; STATUS() ;EXTR VAR to check case status against user's choice N X,Y S X=1,Y=$P(^AQAOC(AQAOIFN,1),U) ;status (open,closed,deleted) I (AQAOSTAT'[1),(Y=0) S X=0 ;open not included in user's choice I (AQAOSTAT'[2),(Y=1) S X=0 ;closed not included in user's choice I (AQAOSTAT'[3),(Y=2) S X=0 ;deleted not included in user's choice Q X ; ; USERTEAM() ;EXTR VAR to check selected user/teams against occ review N W,X,Y,Z S Z=$P($G(^AQAOC(AQAOIFN,1)),U,4) I Z="" Q 0 ;initial reviewer I ('$O(AQAOO("USR",0))),('$O(AQAOO("TEAM",0))) Q 1 ;no restrictions I $$OK Q 1 S Z=$P($G(^AQAOC(AQAOIFN,1)),U,9) I Z="" Q 0 ;initial referral I $$OK Q 1 S (Y,X)=0 F S X=$O(^AQAOC(AQAOIFN,"IADDRV",X)) Q:'X Q:Y=1 D .S Z=$P($G(^AQAOC(AQAOIFN,"IADDRV",X,0)),U) I Z="" Q .I $$OK S Y=1 Q I Y=1 Q 1 ;at least one add referrals S (Y,X)=0 F S X=$O(^AQAOC(AQAOIFN,"REV",X)) Q:'X Q:Y=1 D .S Z=$P($G(^AQAOC(AQAOIFN,"REV",X,0)),U,2) I Z="" Q .I $$OK S Y=1 Q .S W=0 F S W=$O(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W)) Q:'W Q:Y=1 D ..S Z=$P($G(^AQAOC(AQAOIFN,"REV",X,"ADDRV",W,0)),U) I Z="" Q ..I $$OK S Y=1 Q Q Y ; ; OK() ;EXTR VAR to test entry against selection arrays Q ($D(AQAOO("USR",Z)))!($D(AQAOO("TEAM",Z))) AQAOPR72 AQAOPR72 ; IHS/ORDC/LJF - PRINT REVIEWED OCC RPRT ; [ 05/12/95 9:34 AM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn prints the occurrences by indicator listing all reviews ;performed and who performed them. ; INIT ; >>> initialize variables D INIT^AQAOUTIL S AQAOHCON="Patient" S AQAOTY="REVIEWED OCCURRENCES REPORT" S AQAORG=$E(AQAOBD,4,5)_"/"_$E(AQAOBD,6,7)_"/"_$E(AQAOBD,2,3)_" to " S AQAORG=AQAORG_$E(AQAOED,4,5)_"/"_$E(AQAOED,6,7)_"/"_$E(AQAOED,2,3) S AQAONOT=0 ;counter for occ not reviewed K ^TMP("AQAO",$J) ; MAIN ; >>> main calls I '$D(^TMP("AQAOPR7A",$J)) D .D HEADING^AQAOUTIL,HDG1 .W !!,"NO DATA FOUND FOR DATE RANGE SPECIFIED",!! E D LISTING I AQAOSTOP'=U D SUMMARY^AQAOPR73 ; END ; >>> eoj D ^%ZISC I '$D(ZTQUEUED) D PRTOPT^AQAOVAR K ^TMP("AQAOPR7",$J),^TMP("AQAOPR7A",$J),^TMP("AQAO",$J) K AQAOINAC D KILL^AQAOUTIL Q ; ; LISTING ; >> SUBRTN to print occurrence listing if selected D HEADING^AQAOUTIL,HDG1 ; S AQAOIND=0 ;loop by indicator and print occurrences F S AQAOIND=$O(^TMP("AQAOPR7A",$J,AQAOIND)) Q:AQAOIND="" Q:AQAOSTOP=U D .D LIST2 Q:AQAOSTOP=U ;list each occ with reviews Q ; ; LIST2 ; >> SUBRTN for each AQAOIND list occ with reviews I AQAOIND'=0 W !!?AQAOIOMX-$L(AQAOIND)/2,AQAOIND,! S AQAODT=0 F S AQAODT=$O(^TMP("AQAOPR7A",$J,AQAOIND,AQAODT)) Q:AQAODT="" Q:AQAOSTOP=U D .S AQAON=0 .F S AQAON=$O(^TMP("AQAOPR7A",$J,AQAOIND,AQAODT,AQAON)) Q:AQAON="" Q:AQAOSTOP=U D ..S AQAOSTR=$G(^AQAOC(AQAON,0)),AQAOSTR1=$G(^(1)) ;basic occ data ..I $Y>(IOSL-2) D NEWPG^AQAOUTIL Q:AQAOSTOP=U D HDG1 ..S Y=AQAODT X ^DD("DD") W !,$P(AQAOSTR,U),?9,Y ;print case & date ..K ^UTILITY("DIQ1",$J) S DIC="^AQAOC(",DA=AQAON,DR=".025" D EN^DIQ1 ..W ?22,$S(+AQAOSTR1=0:"OPEN",+AQAOSTR1=1:"CLOSED",1:"DELETED") ;status ..; ..D FINDING Q ; ; FINDING ; >> SUBRTN to find findings,etc. for occ ;get initial finding and action S AQAOW=$P($G(^AQAOC(AQAON,1)),U,8) ;review date S AQAOX=$P($G(^AQAOC(AQAON,1)),U,5) ;finding S AQAOY=$P($G(^AQAOC(AQAON,1)),U,4) ;reviewer S AQAOZ=$P($G(^AQAOC(AQAON,1)),U,6) ;action S X=$P($G(^AQAOC(AQAON,1)),U,9) ;referred to;PATCH 3 I X]"" S AQAOAR(1)=X,X=1,Y=0 F S Y=$O(^AQAOC(AQAON,"IADDRV",Y)) Q:Y'=+Y D ;PATCH 3 .S X=X+1,AQAOAR(X)=$P($G(^AQAOC(AQAON,"IADDRV",Y,0)),U) ;addl referrals I AQAOW="" S AQAONOT=AQAONOT+1 Q ;occ not reviewed W !?22,"Reviews:" D PRINTREV K AQAOAR ; S AQAOR=0 F S AQAOR=$O(^AQAOC(AQAON,"REV",AQAOR)) Q:AQAOR'=+AQAOR D .S AQAOW=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,4) ;review date .S AQAOX=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,5) ;finding .S AQAOY=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,2) ;reviewer .S AQAOZ=$P(^AQAOC(AQAON,"REV",AQAOR,0),U,7) ;action .S (X,Y)=0 F S Y=$O(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y)) Q:Y'=+Y D ..S X=X+1,AQAOAR(X)=$P($G(^AQAOC(AQAON,"REV",AQAOR,"ADDRV",Y,0)),U) .D PRINTREV K AQAOAR ; I $P(^AQAOC(AQAON,1),U)=1 D ;closed occurrences .S AQAOW=$P($G(^AQAOC(AQAON,"FINAL")),U) ;review date .S AQAOX=$P($G(^AQAOC(AQAON,"FINAL")),U,4) ;finding .S AQAOY=$P($G(^AQAOC(AQAON,"FINAL")),U,5)_";VA(200," ;reviewer .S AQAOZ=$P($G(^AQAOC(AQAON,"FINAL")),U,6) ;action .D PRINTREV Q ; ; PRINTREV ; SUBRTN to print rev date,reviewer,finding,action Q:AQAOW="" S Y=AQAOW,C=$P(^DD(9002167,.18,0),U,2) D Y^DIQ W ?32,Y ;review date S Y=AQAOY,C=$P(^DD(9002167,.14,0),U,2) D Y^DIQ ;reviewer W ?47,$$NAME I Y]"" S ^TMP("AQAO",$J,Y,AQAOIND,AQAON)="" S Y=$S(AQAOX="":"",1:$P($G(^AQAO(8,AQAOX,0)),U,2)) W ?62,Y ;finding S Y=$S(AQAOZ="":"",1:$P($G(^AQAO(6,AQAOZ,0)),U,2)) W ?72,Y ;action I $D(AQAOAR) S AQAOX=0 F S AQAOX=$O(AQAOAR(AQAOX)) Q:AQAOX="" D .W:AQAOX=1 !?47,"Referred to:" W:AQAOX>1 ! .S Y=AQAOAR(AQAOX),C=$P(^DD(9002167,.19,0),U,2) D Y^DIQ ;referrals .W ?62,$$NAME W ! Q ; ; HDG1 ; >> SUBRTN for second half of heading W ?30,AQAORG,!,AQAOLINE W !,"Case #",?9,"Occ Date",?22,"Status" W ?32,"Rev Date",?47,"Revwr",?62,"Finding",?72,"Action" W !,AQAOLINE Q ; ; HDG2 ; >> SUBRTN for second half of heading2 W ?33,"(SUMMARY PAGE)",!?30,AQAORG,!,AQAOLINE,! Q ; ; NAME() ; >> EXTRN VAR for printing names I Y'["," S Y=$E(Y,1,12) Q Y S Y=$P(Y,",")_","_$E($P(Y,",",2),1),Y=$E(Y,1,12) Q Y AQAOPU1 AQAOPU1 ; IHS/ORDC/LJF - INDICATOR SELECTION ; [ 05/08/95 3:38 PM ] ;;1;QAI MANAGEMENT;**1,2,E1**;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","DIM" D ;ENH1 .I AQAOI="DIM" Q:'$$ENHANCE^AQAOLKP(1) ;ENH1 .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 ..; ..I AQAOI="DIM" D DIMCHK Q ;ENH ..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 AQAOI="DIM" S AQAOF="DIMENSION - "_$P($T(DIM+AQAOS),";;",2) ;ENH1 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 ; ; DIMCHK ; -- SUBRTN to find indicators tied to dimension;ENH1 NEW Y,X S Y=0 F S Y=$O(^AQAO(2,"ADIM",AQAOS,Y)) Q:Y="" D INDCHK^AQAOPU,SET S X=0 F S X=$O(^AQAO1(6,"ADIM",AQAOS,X)) Q:X="" D . S Y=0 . F S Y=$O(^AQAO1(6,X,"IND","B",Y)) Q:Y="" D INDCHK^AQAOPU,SET Q ; ; DIM ;; ;;EFFICACY ;;APPROPRIATENESS ;;AVAILABILITY ;;TIMELINESS ;;EFFECTIVENESS ;;CONTINUITY ;;SAFETY ;;EFFICIENCY ;;RESPECT & CARING AQAOREV AQAOREV ; IHS/ORDC/LJF - ENTER OCCURRENCE REVIEWS ; [ 06/23/95 9:25 AM ] ;;1;QAI MANAGEMENT;**1,3**;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 D ;update prov list;PATCH 3 .S AQAOPT=$O(^AQAQX("B","AQAO PROV LEVEL",0)) Q:AQAOPT="" ;PATCH 3 .K AQAOP D ^AQAOEDTS ;PATCH 3 ; I $D(^XUSEC("AQAOZVAL",DUZ)),$P($G(^AQAO(6,+AQAOACT,0)),U,4)'=1,'$O(^AQAOC(AQAOIFN,"REV",AQAORIFN)),$$ALLREV D ;PATCH 3 .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 ; ; ALLREV() ;EP; -- SUBRTN to return whether referrals covered by reviews;PATCH 3 Q $S($$REFCNT>$$REVCNT:0,1:1) ; REFCNT() ; -- SUBRTN to return # of referrals;PATCH 3 NEW AQAORF,X,Y S AQAORF=0 ; ; -- initial review was referral? I $P($G(^AQAOC(AQAOIFN,1)),U,9)]"" S AQAORF=AQAORF+1 ; -- any additional referrals on initial review? S X=0 F S X=$O(^AQAOC(AQAOIFN,"IADDRV",X)) Q:X'=+X S AQAORF=AQAORF+1 ; ; -- count referrals on other reviews S X=0 F S X=$O(^AQAOC(AQAOIFN,"REV",X)) Q:X'=+X D . I $P($G(^AQAOC(AQAOIFN,"REV",X,0)),U,9)]"" S AQAORF=AQAORF+1 . S Y=0 . F S Y=$O(^AQAOC(AQAOIFN,"REV",X,"ADDRV",Y)) Q:Y'=+Y D .. S AQAORF=AQAORF+1 ; Q AQAORF ; REVCNT() ; -- SUBRTN to return # of reviews;PATCH 3 NEW AQAORV,X S AQAORV=0 S X=0 F S X=$O(^AQAOC(AQAOIFN,"REV",X)) Q:X'=+X S AQAORV=AQAORV+1 Q AQAORV AQAOUHLP AQAOUHLP ; IHS/ORDC/LJF - HELP OPTION ON MAIN MENU ; [ 05/26/95 10:55 AM ] ;;1;QAI MANAGEMENT;**2,3**;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;3:ENHANCEMENTS;4:MANUALS AVAILABLE;5:WHO IS THE PKG ADMINISTRATOR?;6:YOUR ACCESS LEVEL" ;PATCH 2&3 D ^DIR G EXIT:Y<1,EXIT:Y>6 ;PATCH 2&3 S AQAOLIN=$S(Y=1:"INTRO",Y=2:"PATCH",Y=3:"ENHANCE",Y=4:"MANUAL",Y=5:"ADMIN",1:"ACCESS") ;PATCH 2&3 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 D ASK("AQAX QAI PATCHES","AQAX QAI PATCH ") ;PATCH 3 Q ; ENHANCE ; -- SUBRTN calls hlep frames detailing enhancements;PATCH 3 ;PATCH 3: SUBRTN ADDED I '$$ENHANCE^AQAOLKP(1) W !!?10,*7,"NO ENHANCEMENTS INSTALLED",!! Q D ASK("AQAZ ENHANCE MAIN","AQAZ ENHANCE ") Q ; ASK(AQAOHF,AQAOHF1) ; -- SUBRTN to ask user to view or print help ;PATCH 3: SUBRTN ADDED NEW DIR,X,Y,XQH W @IOF,!!?20,"QUICK ON-LINE HELP UTILITY",!! K DIR S DIR(0)="NO^1:2",DIR("A")=" Select option by number" S DIR("A",1)=" How do you want me to present this help?" S DIR("A",2)=" " S DIR("A",3)=" 1. DISPLAY help to your screen" S DIR("A",4)=" 2. PRINT help to your printer" S DIR("A",5)=" " D ^DIR G EXIT:$D(DIRUT) ; I Y=1 S XQH=AQAOHF D EN^XQH Q I Y=2 D CHOOSE(AQAOHF1) Q ; CHOOSE(AQAOH) ; -- SUBRTN so user can choose which help to print ;PATCH 3: SUBRTN ADDED NEW DIR,Y,I,J,XQHFY,XQFMT S J=0 F I=1:1 Q:'$D(^DIC(9.2,"B",AQAOH_I)) S J=I Q:J=0 I J=1 S Y=1 D SEND Q W !! K DIR S DIR(0)="NO^1:"_J S DIR("A")=" Print which "_$S(AQAOH["PATCH":"PATCH",1:"ENHANCEMENT") D ^DIR Q:Y<1 SEND S XQHFY=AQAOH_Y,XQFMT="T" D ACTION^XQH4 Q ; 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 AQAOVAL AQAOVAL ; IHS/ORDC/LJF - CLOSE OUT OCCURRENCES ; [ 05/11/95 10:14 AM ] ;;1;QAI MANAGEMENT;**3**;AUG 15, 1994 ; ;This rtn contains the user interface to close out an occurrence ;after all reviews have been performed. This can be called from ;the review process if the user has access and the action was not ;a referral. ; ASK ; >>> ask for occ id or patient name or indicator G EXIT:$D(AQAOENTR) ;called by ^AQAOENTR D ASK^AQAOLKP G EXIT:'$D(AQAOIFN),EXIT:$D(DUOUT),EXIT:$D(DTOUT) ; 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 ; FIND ; >> find all reviews for this occurrence D FIND^AQAOREV1 ; ; CLOSE ;ENTRY POINT >>> close out occurrence W ! K DIR S DIR(0)="Y",DIR("B")="NO" S DIR("?",1)="Enter YES if the review process has been completed and" S DIR("?",2)="validated for this occurrence.",DIR("?")=" " S DIR("A")="Do you wish to CLOSE OUT this Occurrence" D ^DIR G EXIT:$D(DIRUT),ASK:Y'=1 ; I '$$ALLREV^AQAOREV D G EXIT:$D(DIRUT),ASK:Y'=1 ;PATCH 3 . W !!,*7,"There appears to be some outstanding referrals" ;PATCH 3 . W ! K DIR S DIR(0)="Y",DIR("B")="NO" ;PATCH 3 . S DIR("A")="Are you SURE you want to close out this occurrence" ;PATCH 3 . D ^DIR ;PATCH 3 L +^AQAGU(0):1 I '$T W !!,"CANNOT CLOSE; AUDIT FILE LOCKED. TRY AGAIN!",! G ASK L +^AQAOC(AQAOIFN):1 I '$T W !!,"CANNOT CLOSE; ANOTHER USER EDITING OCCURRENCE.",! G ASK W !!!?5,"Closing out Occurrence #",AQAOCID,". . . .",!! S AQAOUDIT("DA")=AQAOIFN,AQAOUDIT("ACTION")="C" S AQAOUDIT("COMMENT")="CLOSE OUT RECORD" D ^AQAOAUD K DIE S DIE="^AQAOC(",DA=AQAOIFN I '$O(^AQAOC(AQAOIFN,"REV",0)) D I 1 .S X=^AQAOC(AQAOIFN,1) K AQAOCLS .S AQAOCLS(2)=$P(X,U,3),AQAOCLS(3)=$P(X,U,11),AQAOCLS(4)=$P(X,U,5) .S AQAOCLS(6)=$P(X,U,6),AQAOCLS(7)=$P(X,U,7) .S DR="[AQAO INITIAL CLOSE]" D ^DIE L -^AQAOC(AQAOIFN) E I $D(AQAORIFN) D I 1 .K DIR S DIR(0)="Y" .S DIR("A")="Should I use this review as the final say for this occurrence" .S DIR("?",1)="Do you wish to use your answers for this review as the" .S DIR("?",2)="final ones for this occurrence?" .S DIR("?",3)="If you answer YES, I will automatically stuff your" .S DIR("?",4)="answers from this review as the final ones." .S DIR("?",5)="If you answer NO, I will ask you to answer each" .S DIR("?",6)="question for the final say on this occurrence" .S DIR("?")=" " D ^DIR .I Y=1 D I 1 ;stuff answers ..S X=^AQAOC(AQAOIFN,"REV",AQAORIFN,0) K AQAOCLS ..S AQAOCLS(2)=$P(X,U),AQAOCLS(3)=$P(X,U,11),AQAOCLS(4)=$P(X,U,5) ..S AQAOCLS(6)=$P(X,U,7),AQAOCLS(7)=$P(X,U,6) ..S DR="[AQAO INITIAL CLOSE]" D ^DIE L -^AQAOC(AQAOIFN) .E S DR="[AQAO CLOSE OUT]" D ^DIE L -^AQAOC(AQAOIFN) E S DR="[AQAO CLOSE OUT]" D ^DIE L -^AQAOC(AQAOIFN) I '$D(Y) D .S AQAOACT=$P(^AQAOC(AQAOIFN,"FINAL"),U,6) ;action .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 ;calls data entry driver .I $P(^AQAOC(AQAOIFN,"FINAL"),U,2)>1 D ;not for non-clin prelim ..S AQAOPT=$O(^AQAQX("B","AQAO PROV LEVEL",0)) Q:AQAOPT="" ..K AQAOP D ^AQAOEDTS .W !! K DIR S DIR(0)="E" .S DIR("A")="Occurrence Closed. Press RETURN to continue" D ^DIR ; ; EXIT ; >> eoj D KILL^AQAOUTIL G EXIT1:$D(AQAOENTR) W ! K DIR S DIR(0)="Y",DIR("B")="NO" S DIR("A")="Do you wish to CLOSE OUT another occurrence" D ^DIR G EXIT1:$D(DIRUT),ASK:Y=1 EXIT1 K DIR,DIC Q ; ; SUM ; >> SUBRTN to print occurrence summary N AQAOIFN,AQAORVW,AQAOARR,AQAOCID,AQAOPAT,AQAOIND,AQAODATE S AQAOIFN=X S X=$P(^AQAOC(AQAOIFN,0),U,2),AQAOARR(AQAOIFN)=$P(^DPT(X,0),U) S AQAODEV="HOME" D PRINT^AQAOPR3 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 AQAOYP2 AQAOYP2 ;IHS/ORDC/LJF - PATCH #2 DRIVER; [ 06/23/95 10:34 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 AQAOYP3 AQAOYP3 ;IHS/ORDC/LJF - PATCH #3 DRIVER; [ 06/23/95 10:34 AM ] ;;1;QAI MANAGEMENT;**3**;AUGUST 15, 1994 ; W !!?20,"QAI PATCH 3 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 #3 ; -- install 3 print templates & 4 input templates W !!,"First I need to run an init to install some templates:" W !?5,"Print templates: AQAO ACTION LIST" W !?5," AQAO FINDINGS LIST" W !?5," AQAO WORKSHEET" W !?5,"Input template: AQAO RATE REVIEW" W !?5," AQAO PROV ACTION EDIT" W !?5," AQAO PROV ACTION ADD" W !?5," AQAO PROV LEVEL ADD" W !,"And the Help Frames detailing the QAI 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 from patch 2 D CUMP2^AQAOYP2 ; ; -- update D CUMP3 ; ; -- inform users patch has been installed D MAIL ; ; EXIT ; -- eoj W !!,"PATCH #3 INSTALLED!",! Q ; CUMP3 ;EP -- to be called by future patches D 1,2 Q 1 ; -- SUBRTN edit qi data entry option W !!,"Updating QI Data Entry so provider add function works" W !,"during review process.",! NEW X,DIC,Y,DIE,DA,DR S X="AQAO ACTION LEVEL",DIC="^AQAQX(",DIC(0)="" D ^DIC Q:Y=-1 S DIE="^AQAQX(",DA=+Y,DR=".01///AQAO PROVIDER;.02///PROVIDER ADD" D ^DIE S DA(1)=DA,DA=1,DIE="^AQAQX("_DA(1)_",""PG""," S DR=".03///UPDATE PROVIDER LIST;.12///[AQAO PROVIDER" D ^DIE Q ; 2 ; -- SUBRTN to edit help text on inactive fields W !!,"Fixing help text on Inactive fields.",! NEW AQAOI,AQAO,X,Y,Z S AQAO("ACTIVATE")="REACTIVATE",AQAO("activate")="REACTIVATE" F AQAOI=1:1:3 D . S Y=$P($T(FILE+AQAOI),";;",2),Z=$P($T(FILE+AQAOI),";;",3) . S X=^DD(Y,Z,3),^DD(Y,Z,3)=$$REPLACE^XLFSTR(X,.AQAO) Q ; MAIL ; -- SUBRTN to send mail message NEW AQAOI,AQAO,XMTEXT,XMSUB,XMY S XMSUB="QAI PATCH #3 INSTALLED",XMTEXT="AQAO(" F AQAOI=1:1:8 S AQAO(AQAOI)=$P($T(MSG+AQAOI),";;",2) S X=0 F S X=$O(^XUSEC("AQAOZMENU",X)) Q:X="" S XMY(X)="",XMY(X,1)="I" D ^XMD W !!,"Mail message sent to all QAI users.",! Q ; FILE ;; ;;9002168.6;;.05;;QI ACTION file INACTIVE field ;;9002168.8;;.04;;QI FINDINGS file INACTIVE field ;;9002169.3;;.03;;QI LEVEL file INACTIVE field ; MSG ;; ;;***************************************************************** ;; Congratulations! ;;The QAI PATCH #3 has just been installed on your computer system! ;;***************************************************************** ;; ;;For your convenience all the changes are documented on-line for ;;you. Use the option "HELP on Using QAI Package" and select choice ;;#2 for PATCHES. It will tell you what has been fixed. Have fun! AQAQEDT AQAQEDT ;IHS/ANMC/LJF - MAIN DRIVER FOR DATA ENTRY; [ 04/03/95 7:14 AM ] ;;2.2;STAFF CREDENTIALS;**7**;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 S AQAQXLF(".")=",",Y=$$REPLACE^XLFSTR(Y,.AQAQXLF) K AQAQXLF ;PATCH #7 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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",1840,0) ;;=AQAO PROV ACTION EDIT^2931208.0848^^9002166.7^10^^2940707 ;;^UTILITY(U,$J,"DIE",1840,"DR",1,9002166.7) ;;=I $P(^AQAOCC(7,DA,0),U,6)]"" S Y="@1";.06////^S X=$S($D(AQAOACT):AQAOACT,1:"");W !!,"PROVIDER FLAGGED.",!;S Y="@2";@1;.06////@;W !!,"PROVIDER UNFLAGGED.",!;@2; ;;^UTILITY(U,$J,"DIE",1840,"ROU") ;;=^AQAOT06 ;;^UTILITY(U,$J,"DIE",1840,"ROUOLD") ;;=AQAOT06 ;;^UTILITY(U,$J,"DIE",1857,0) ;;=AQAO RATE REVIEW^2950313.1307^^9002167^0^^2950313 ;;^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,"DIE",2037,0) ;;=AQAO PROV ACTION ADD^2950511.0758^@^9002167^297^@^2950511 ;;^UTILITY(U,$J,"DIE",2037,"DIAB",1,0,9002167,0) ;;=QI OCC PROVIDER: ;;^UTILITY(U,$J,"DIE",2037,"DR",1,9002167) ;;=^9002166.7^AQAOCC(7,^^S I(0,0)=$S($D(D0):D0,1:"") X DR(99,1,9.2) S X=$S(D0>0:D0,1:""),D(0)=X S D0=I(0,0) S X=$S(D(0)>0:D(0),1:""); ;;^UTILITY(U,$J,"DIE",2037,"DR",2,9002166.7) ;;=.03////^S X=AQAOPAT;.05;.06////^S X=$S($D(AQAOACT):AQAOACT,1:"");W !!,"PROVIDER FLAGGED.",!; ;;^UTILITY(U,$J,"DIE",2037,"DR",99,1,9.2) ;;=S DIC=9002166.7,DIADD=1,DIC(0)="EQLAM",DIC("S")="I $D(^AQAOCC(7,""AB"",I(0,0),Y))" D ^DIC K DIADD S D0=+Y,DIC(.02)=I(0,0),DIH=9002166.7 D DICL^DICR:$P(Y,U,3) K DIC ;;^UTILITY(U,$J,"DIE",2038,0) ;;=AQAO PROV LEVEL ADD^2950511.0801^@^9002167^297^@^2950511 ;;^UTILITY(U,$J,"DIE",2038,"DIAB",1,0,9002167,0) ;;=QI OCC PROVIDER: ;;^UTILITY(U,$J,"DIE",2038,"DR",1,9002167) ;;=^9002166.7^AQAOCC(7,^^S I(0,0)=$S($D(D0):D0,1:"") X DR(99,1,9.2) S X=$S(D0>0:D0,1:""),D(0)=X S D0=I(0,0) S X=$S(D(0)>0:D(0),1:""); ;;^UTILITY(U,$J,"DIE",2038,"DR",2,9002166.7) ;;=.03////^S X=AQAOPAT;.05;.07; ;;^UTILITY(U,$J,"DIE",2038,"DR",99,1,9.2) ;;=S DIC=9002166.7,DIADD=1,DIC(0)="EQLAM",DIC("S")="I $D(^AQAOCC(7,""AB"",I(0,0),Y))" D ^DIC K DIADD S D0=+Y,DIC(.02)=I(0,0),DIH=9002166.7 D DICL^DICR:$P(Y,U,3) K DIC ;;^UTILITY(U,$J,"DIPT",4129,0) ;;=AQAO WORKSHEET^2950512.0948^@^9002168.2^297^@^2950512 ;;^UTILITY(U,$J,"DIPT",4129,"DXS",1,9) ;;=X DXS(1,9.2) S X=X="YES",DIP(3)=X S X="VISIT/ADMIT DATE: __________________",DIP(4)=X S X=1,DIP(5)=X S X="",X=$S(DIP(3):DIP(4),DIP(5):X) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",1,9.2) ;;=S DIP(2)=$C(59)_$S($D(^DD(9002168.2,.12,0)):$P(^(0),U,3),1:""),DIP(1)=$S($D(^AQAO(2,D0,1)):^(1),1:"") S X=$P($P(DIP(2),$C(59)_$P(DIP(1),U,2)_":",2),$C(59),1) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",2,9.2) ;;=S DIP(2)=$C(59)_$S($D(^DD(9002168.2,.12,0)):$P(^(0),U,3),1:""),DIP(1)=$S($D(^AQAO(2,D0,1)):^(1),1:"") S X=$P($P(DIP(2),$C(59)_$P(DIP(1),U,2)_":",2),$C(59),1) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",3,9.2) ;;=S DIP(2)=$C(59)_$S($D(^DD(9002168.2,.12,0)):$P(^(0),U,3),1:""),DIP(1)=$S($D(^AQAO(2,D0,1)):^(1),1:"") S X=$P($P(DIP(2),$C(59)_$P(DIP(1),U,2)_":",2),$C(59),1) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",4,9) ;;=X DXS(4,9.2) S X=X="YES",DIP(3)=X S X="SERVICE: __________________",DIP(4)=X S X=1,DIP(5)=X S X="",X=$S(DIP(3):DIP(4),DIP(5):X) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",4,9.2) ;;=S DIP(2)=$C(59)_$S($D(^DD(9002168.2,.12,0)):$P(^(0),U,3),1:""),DIP(1)=$S($D(^AQAO(2,D0,1)):^(1),1:"") S X=$P($P(DIP(2),$C(59)_$P(DIP(1),U,2)_":",2),$C(59),1) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",5,9) ;;=X DXS(5,9.2) S DIP(204)=X S X="",DIP(205)=X S X=1,DIP(206)=X S X=$P(DIP(201),U,3)_":",X=$S(DIP(202):DIP(203),DIP(204):DIP(205),DIP(206):X) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",5,9.2) ;;=S DIP(201)=$S($D(^AQAQX(D0,"PG",D1,0)):^(0),1:"") S X=$P(DIP(201),U,3)="GENERAL OCCURRENCE DATA",DIP(202)=X S X="",DIP(203)=X S X=$P(DIP(201),U,3)="REVIEW CRITERIA" ;;^UTILITY(U,$J,"DIPT",4129,"DXS",6,9.2) ;;=S D=0 F S (D,D0)=$O(^AQAO1(6,"C",I(0,0),D)) S:D="" (D,D0)=-1 Q:D'>0 I $D(^AQAO1(6,D,0)) S X=$P(^(0),U,1) S DIXX=DIXX(1) D M Q:'$D(D) S D=D0 ;;^UTILITY(U,$J,"DIPT",4129,"DXS",7,9) ;;=X DXS(7,9.6) S X=$S(DIP(103):DIP(104),DIP(106):DIP(107),DIP(109):DIP(110),DIP(111):X) ;;^UTILITY(U,$J,"DIPT",4129,"DXS",7,9.2) ;;=S DIP(102)=$C(59)_$S($D(^DD(9002169.6,.02,0)):$P(^(0),U,3),1:""),DIP(105)=$C(59)_$S($D(^DD(9002169.6,.02,0)):$P(^(0),U,3),1:"") AQAXI002 AQAXI002 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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,"DIPT",4129,"DXS",7,9.3) ;;=X DXS(7,9.2) S DIP(108)=$C(59)_$S($D(^DD(9002169.6,.02,0)):$P(^(0),U,3),1:""),DIP(101)=$S($D(^AQAO1(6,D0,0)):^(0),1:"") ;;^UTILITY(U,$J,"DIPT",4129,"DXS",7,9.4) ;;=X DXS(7,9.3) S X=$P($P(DIP(102),$C(59)_$P(DIP(101),U,2)_":",2),$C(59),1)="YES/NO/NA",DIP(103)=X S X="YES / NO / NA",DIP(104)=X ;;^UTILITY(U,$J,"DIPT",4129,"DXS",7,9.5) ;;=X DXS(7,9.4) S X=$P($P(DIP(105),$C(59)_$P(DIP(101),U,2)_":",2),$C(59),1)="DATE",DIP(106)=X S X="___/___/____",DIP(107)=X ;;^UTILITY(U,$J,"DIPT",4129,"DXS",7,9.6) ;;=X DXS(7,9.5) S X=$P($P(DIP(108),$C(59)_$P(DIP(101),U,2)_":",2),$C(59),1)="NUMBER",DIP(109)=X S X="____",DIP(110)=X S X=1,DIP(111)=X S X="" ;;^UTILITY(U,$J,"DIPT",4129,"DXS",8,"R") ;;=RATE-BASED ;;^UTILITY(U,$J,"DIPT",4129,"DXS",8,"S") ;;=SENTINEL ;;^UTILITY(U,$J,"DIPT",4129,"F",1) ;;=.01;C1~.02;C10~.04;C50~.05;C60~ ;;^UTILITY(U,$J,"DIPT",4129,"F",2) ;;=2,-9002168.1,^AQAO(1,^^S I(1,0)=D1 S I(0,0)=D0 S DIP(1)=$S($D(^AQAO(2,D0,"AOC",D1,0)):^(0),1:"") S X=$P(DIP(1),U,1),X=X S D(0)=+X;Z;".01:"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",3) ;;="PATIENT ID: ";C8;S1~"__________________";X~"OCCURRENCE DATE: ";C41~"_________________";X~ ;;^UTILITY(U,$J,"DIPT",4129,"F",4) ;;=X DXS(1,9) W X K DIP;C2;Z;"$S(VISIT RELATED?="YES":"VISIT/ADMIT DATE: __________________",1:"")"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",5) ;;=X DXS(2,9.2) S X=X="YES",DIP(3)=X S X="WARD/CLINIC: ",DIP(4)=X S X=1,DIP(5)=X S X="",X=$S(DIP(3):DIP(4),DIP(5):X) W X K DIP;C45;Z;"$S(VISIT RELATED?="YES":"WARD/CLINIC: ",1:"")"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",6) ;;=X DXS(3,9.2) S X=X="YES",DIP(3)=X S X="_________________",DIP(4)=X S X=1,DIP(5)=X S X="",X=$S(DIP(3):DIP(4),DIP(5):X) W X K DIP;X;Z;"$S(VISIT RELATED?="YES":"_________________",1:"")"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",7) ;;=X DXS(4,9) W X K DIP;C11;Z;"$S(VISIT RELATED?="YES":"SERVICE: __________________",1:"")"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",8) ;;=-9002168.3,^AQAO(3,^^S I(0,0)=D0 S DIP(1)=$S($D(^AQAO(2,D0,1)):^(1),1:"") S X=$P(DIP(1),U,1),X=X S D(0)=+X;Z;"TYPE OF REVIEW PERFORMED:"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",9) ;;=-9002168.3,-9002166.1,^AQAQX(^^S I(100,0)=D0 S DIP(101)=$S($D(^AQAO(3,D0,0)):^(0),1:"") S X=$P(DIP(101),U,3),X=X S D(0)=+X;Z;"DATA ENTRY LINK:"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",10) ;;=-9002168.3,-9002166.1,1,X DXS(5,9) W X K DIP;C1;S1;Z;"$S(SCREEN TITLE="GENERAL OCCURRENCE DATA":"",SCREEN TITLE="REVIEW CRITERIA":"",1:SCREEN TITLE_":")"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",11) ;;="REVIEW CRITERIA";C30~"===============";C30~-9002169.6,^AQAO1(6,^1^S I(0,0)=$S($D(D0):D0,1:"") X DXS(6,9.2) S X="" S D0=I(0,0);Z;"QI REVIEW CRITERIA:"~ ;;^UTILITY(U,$J,"DIPT",4129,"F",12) ;;=-9002169.6,S DIP(101)=$S($D(^AQAO1(6,D0,0)):^(0),1:"") S X=$P(DIP(101),U,1)_": " W X K DIP;C1;S1;Z;"PHRASE_": ""~ ;;^UTILITY(U,$J,"DIPT",4129,"F",13) ;;=-9002169.6,X DXS(7,9) W X K DIP;C60;Z;"$S(TYPE="YES/NO/NA":"YES / NO / NA",TYPE="DATE":"___/___/____",TYPE="NUMBER":"____",1:"")"~-9002169.6," ";C79~ ;;^UTILITY(U,$J,"DIPT",4129,"F",14) ;;=-9002169.6,1," ";X~-9002169.6,1,.01;X;~-9002169.6,1," ";X~"COMPLETED ON ___________________";C1;S2~"BY ______________________________";C35~ ;;^UTILITY(U,$J,"DIPT",4129,"F",15) ;;="CASE SUMMARY:";C1;S1~ ;;^UTILITY(U,$J,"DIPT",4129,"H") ;;=[AQAO WRKST HEADING] ;;^UTILITY(U,$J,"DIPT",4129,"IOM") ;;=80 ;;^UTILITY(U,$J,"DIPT",4129,"LAST") ;;= ;;^UTILITY(U,$J,"DIPT",4129,"ROU") ;;=^AQAOT78 ;;^UTILITY(U,$J,"DIPT",4129,"ROUOLD") ;;=AQAOT78 ;;^UTILITY(U,$J,"DIPT",4136,0) ;;=AQAO ACTION LIST^2950309.1413^^9002168.6^297^^2950309 ;;^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^297^^2950309 ;;^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) AQAXI003 AQAXI003 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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,"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^2950523.1413^^ ;;^UTILITY(U,$J,"HEL",1541,1,0) ;;=^^16^16^2950523^ ;;^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) ;;= PATCH [3 ]: Released June 1995 ;;^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^3^3 ;;^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",1541,2,3,0) ;;=3 ^AQAX QAI PATCH 3 ;;^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 ;;^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. AQAXI004 AQAXI004 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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",1622,0) ;;=AQAX QAI PATCH 3^QAI V1 PATCH 3^2950523.1429^ ;;^UTILITY(U,$J,"HEL",1622,1,0) ;;=^^21^21^2950523^ ;;^UTILITY(U,$J,"HEL",1622,1,1,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,2,0) ;;= 1. If you are asked for a visit date while entering occurrences, the ;;^UTILITY(U,$J,"HEL",1622,1,3,0) ;;= computer will continue to ask for a visit date until you find the ;;^UTILITY(U,$J,"HEL",1622,1,4,0) ;;= correct one or enter an "^". ;;^UTILITY(U,$J,"HEL",1622,1,5,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,6,0) ;;= 2. Fixed so only Action Plans for your facility show up on your To-Do ;;^UTILITY(U,$J,"HEL",1622,1,7,0) ;;= List and Tickler Report. No more phantom Action Plans showing up. ;;^UTILITY(U,$J,"HEL",1622,1,8,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,9,0) ;;= 3. Fixed so you can add and edit providers during review process and ;;^UTILITY(U,$J,"HEL",1622,1,10,0) ;;= while closing a case. And the ADD A NEW ENTRY works now! ;;^UTILITY(U,$J,"HEL",1622,1,11,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,12,0) ;;= 4. Fixed closing process. Cannot close occurrence during review process ;;^UTILITY(U,$J,"HEL",1622,1,13,0) ;;= if there are outstanding referrals. You are warned of outstanding ;;^UTILITY(U,$J,"HEL",1622,1,14,0) ;;= referrals when you try to close under the Validate option. Cannot ;;^UTILITY(U,$J,"HEL",1622,1,15,0) ;;= close Action Plans prior to Proposed Review Date. ;;^UTILITY(U,$J,"HEL",1622,1,16,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,17,0) ;;= 5. Fixed Trending Reports so they work properly in a multiple-facility ;;^UTILITY(U,$J,"HEL",1622,1,18,0) ;;= environment. Fixed Single Criterion by Month report in ASCII format. ;;^UTILITY(U,$J,"HEL",1622,1,19,0) ;;= ;;^UTILITY(U,$J,"HEL",1622,1,20,0) ;;= 6. Cleaned up Reviewed Occurrences Report so phrase "Referred to:" is ;;^UTILITY(U,$J,"HEL",1622,1,21,0) ;;= only printed for cases where referral was actually made. ;;^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^2950523 ;;^UTILITY(U,$J,"PKG",329,22,"B",1,1) ;;= ;;^UTILITY(U,$J,"PKG",329,"DIE",0) ;;=^9.47^4^4 ;;^UTILITY(U,$J,"PKG",329,"DIE",1,0) ;;=AQAO RATE REVIEW^9002167 ;;^UTILITY(U,$J,"PKG",329,"DIE",2,0) ;;=AQAO PROV ACTION EDIT^9002166.7 ;;^UTILITY(U,$J,"PKG",329,"DIE",3,0) ;;=AQAO PROV ACTION ADD^9002167 ;;^UTILITY(U,$J,"PKG",329,"DIE",4,0) ;;=AQAO PROV LEVEL ADD^9002167 ;;^UTILITY(U,$J,"PKG",329,"DIPT",0) ;;=^9.46^3^3 ;;^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 ;;^UTILITY(U,$J,"PKG",329,"DIPT",3,0) ;;=AQAO WORKSHEET^9002168.2 AQAXINI1 AQAXINI1 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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:4 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 ; ; 26-MAY-1995 ;;1;QAI PATCHES;;MAY 23, 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 26-MAY-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