Released ACKQ*3*15 SEQ #11 Extracted from mail message **KIDS**:ACKQ*3.0*15^ **INSTALL NAME** ACKQ*3.0*15 "BLD",7150,0) ACKQ*3.0*15^QUASAR^0^3070313^y "BLD",7150,1,0) ^^1^1^3061213^ "BLD",7150,1,1,0) INCORRECT DIAGNOSTIC CODE DISPLAY "BLD",7150,4,0) ^9.64PA^^ "BLD",7150,6) 1^ "BLD",7150,6.3) 2 "BLD",7150,"ABPKG") n "BLD",7150,"KRN",0) ^9.67PA^8989.52^19 "BLD",7150,"KRN",.4,0) .4 "BLD",7150,"KRN",.401,0) .401 "BLD",7150,"KRN",.402,0) .402 "BLD",7150,"KRN",.403,0) .403 "BLD",7150,"KRN",.5,0) .5 "BLD",7150,"KRN",.84,0) .84 "BLD",7150,"KRN",3.6,0) 3.6 "BLD",7150,"KRN",3.8,0) 3.8 "BLD",7150,"KRN",9.2,0) 9.2 "BLD",7150,"KRN",9.8,0) 9.8 "BLD",7150,"KRN",9.8,"NM",0) ^9.68A^3^3 "BLD",7150,"KRN",9.8,"NM",1,0) ACKQAS^^0^B84273699 "BLD",7150,"KRN",9.8,"NM",2,0) ACKQASU^^0^B21282151 "BLD",7150,"KRN",9.8,"NM",3,0) ACKQUTL2^^0^B36429038 "BLD",7150,"KRN",9.8,"NM","B","ACKQAS",1) "BLD",7150,"KRN",9.8,"NM","B","ACKQASU",2) "BLD",7150,"KRN",9.8,"NM","B","ACKQUTL2",3) "BLD",7150,"KRN",19,0) 19 "BLD",7150,"KRN",19.1,0) 19.1 "BLD",7150,"KRN",101,0) 101 "BLD",7150,"KRN",409.61,0) 409.61 "BLD",7150,"KRN",771,0) 771 "BLD",7150,"KRN",870,0) 870 "BLD",7150,"KRN",8989.51,0) 8989.51 "BLD",7150,"KRN",8989.52,0) 8989.52 "BLD",7150,"KRN",8994,0) 8994 "BLD",7150,"KRN","B",.4,.4) "BLD",7150,"KRN","B",.401,.401) "BLD",7150,"KRN","B",.402,.402) "BLD",7150,"KRN","B",.403,.403) "BLD",7150,"KRN","B",.5,.5) "BLD",7150,"KRN","B",.84,.84) "BLD",7150,"KRN","B",3.6,3.6) "BLD",7150,"KRN","B",3.8,3.8) "BLD",7150,"KRN","B",9.2,9.2) "BLD",7150,"KRN","B",9.8,9.8) "BLD",7150,"KRN","B",19,19) "BLD",7150,"KRN","B",19.1,19.1) "BLD",7150,"KRN","B",101,101) "BLD",7150,"KRN","B",409.61,409.61) "BLD",7150,"KRN","B",771,771) "BLD",7150,"KRN","B",870,870) "BLD",7150,"KRN","B",8989.51,8989.51) "BLD",7150,"KRN","B",8989.52,8989.52) "BLD",7150,"KRN","B",8994,8994) "BLD",7150,"QUES",0) ^9.62^^ "BLD",7150,"REQB",0) ^9.611^1^1 "BLD",7150,"REQB",1,0) ACKQ*3.0*10^2 "BLD",7150,"REQB","B","ACKQ*3.0*10",1) "MBREQ") 0 "PKG",262,-1) 1^1 "PKG",262,0) QUASAR^ACKQ^Audiology & Speech Pathology Visit Tracking System "PKG",262,20,0) ^9.402P^^ "PKG",262,22,0) ^9.49I^1^1 "PKG",262,22,1,0) 3.0^3000211^3000503^1556 "PKG",262,22,1,"PAH",1,0) 15^3070313^33270 "PKG",262,22,1,"PAH",1,1,0) ^^1^1^3070313 "PKG",262,22,1,"PAH",1,1,1,0) INCORRECT DIAGNOSTIC CODE DISPLAY "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") YES "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") YES "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 3 "RTN","ACKQAS") 0^1^B84273699^B84322595 "RTN","ACKQAS",1,0) ACKQAS ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits ; 04/01/99 "RTN","ACKQAS",2,0) ;;3.0;QUASAR;**1,10,15**;Feb 11, 2000;Build 2 "RTN","ACKQAS",3,0) ;Call DEM^VADPT supported by DBIA #10061 "RTN","ACKQAS",4,0) ; "RTN","ACKQAS",5,0) ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. "RTN","ACKQAS",6,0) ; "RTN","ACKQAS",7,0) IVD ; INITIAL VISIT DATE ** TRIGGERED FROM PATIENT NAME *** "RTN","ACKQAS",8,0) N Y,DDD,DD,DFN,D0,%DT "RTN","ACKQAS",9,0) S DFN=X,X=$S('$D(^ACK(509850.2,DFN,0)):"",'$P(^(0),U,2):"",1:$P(^(0),U,2)) "RTN","ACKQAS",10,0) I 'X D "RTN","ACKQAS",11,0) . F D Q:X=""!(X'>DT) "RTN","ACKQAS",12,0) .. S Y=ACKVD D DD^%DT S %DT="AEP",%DT("A")="INITIAL VISIT DATE: " "RTN","ACKQAS",13,0) .. S %DT("B")=Y D ^%DT K %DT S X=$S(Y<1:"",1:Y) "RTN","ACKQAS",14,0) .. I X>DT W !,"No Future Dates Allowed",! "RTN","ACKQAS",15,0) K A1 "RTN","ACKQAS",16,0) Q "RTN","ACKQAS",17,0) ; "RTN","ACKQAS",18,0) VISIT ; New visit data input "RTN","ACKQAS",19,0) N ACKOUT "RTN","ACKQAS",20,0) I '$O(^ACK(509850.8,0)) W !,"A&SP site parameters must be established before visits can be entered.",! Q "RTN","ACKQAS",21,0) ; "RTN","ACKQAS",22,0) D LIST^DIC(509850.83,",1,",".01","I","*","","","","","","ACKTRGT","ACKMSG") "RTN","ACKQAS",23,0) I '$P($G(ACKTRGT("DILIST",0)),U,1) W !,"No Divisions have been set up select the Site Parameters function to set up",!,"Division entries.",! Q "RTN","ACKQAS",24,0) ; "RTN","ACKQAS",25,0) ; Get the Division "RTN","ACKQAS",26,0) DIV ; "RTN","ACKQAS",27,0) I $D(ACKDVN),$D(CLINVARR),$P($G(ACKDVN),U,2)=1,$G(CLINVARR)<2 G VEXIT "RTN","ACKQAS",28,0) D VEXIT "RTN","ACKQAS",29,0) S ACKDVN=$$DIV^ACKQUTL2(1,.ACKDIV) G:$P(ACKDVN,U,1)="0" VEXIT "RTN","ACKQAS",30,0) I '$P(ACKDVN,U,2) W !!!!!,"No Active Divisions Set up on Site Parameters File" W ! H 1 G VEXIT "RTN","ACKQAS",31,0) S ACKDIV=$O(ACKDIV("")),ACKDIV=$P(ACKDIV(ACKDIV),U,1) ; use division IEN of Parameter file "RTN","ACKQAS",32,0) I $P(ACKDVN,U,2)>1 W " Station Number : "_$$GET1^DIQ(40.8,ACKDIV,1) "RTN","ACKQAS",33,0) ; "RTN","ACKQAS",34,0) ; Get clinic "RTN","ACKQAS",35,0) CLIN S ACKCLIN=$$CLIN^ACKQASU1(ACKDIV,"U") G:ACKCLIN=""&($P($G(ACKDVN),U,2)=1) VEXIT G:ACKCLIN="" DIV "RTN","ACKQAS",36,0) I ACKCLIN=0 W !!!!!,"No Clinics set up for Division " W ! H 1 G DIV "RTN","ACKQAS",37,0) S ACKCLIN=$P(ACKCLIN,U,1) ; Use clinic IEN from Clinic file "RTN","ACKQAS",38,0) ; Get Clinic stop code "RTN","ACKQAS",39,0) D STOP "RTN","ACKQAS",40,0) ; "RTN","ACKQAS",41,0) W !!!,"Clinic: ",$$GET1^DIQ(44,ACKCLIN,.01)," Stop Code: ",ACKCSC(1) "RTN","ACKQAS",42,0) ; "RTN","ACKQAS",43,0) ; Get visit date "RTN","ACKQAS",44,0) VDATE S DIR(0)="D^:DT:AEX",DIR("A")="Enter Visit Date",DIR("B")="TODAY" "RTN","ACKQAS",45,0) S DIR("?")="Enter the visit date or press return for TODAY. Future dates not allowed",DIR("??")="^D HELP^%DTC" "RTN","ACKQAS",46,0) D ^DIR K DIR I X?1"^"1.E W !,"Jumping not allowed." G VDATE "RTN","ACKQAS",47,0) G:$D(DIRUT) DIV "RTN","ACKQAS",48,0) S ACKVD=Y "RTN","ACKQAS",49,0) ; "RTN","ACKQAS",50,0) ; "RTN","ACKQAS",51,0) PATIENT S DIC="^ACK(509850.2,",DIC(0)="AEMQL",DLAYGO=509850.2 "RTN","ACKQAS",52,0) S DIC("W")="N ACKA,ACKB S ACKA=$$GET1^DIQ(2,Y,.03),ACKB=$$GET1^DIQ(2,Y,.09),ACKA=$E(ACKA,1,2)_""-""_$E(ACKA,4,5)_""-""_$E(ACKA,9,10) W ?36,ACKA_"" ""_ACKB" "RTN","ACKQAS",53,0) S ACKLAYGO="" D ^DIC I X?1"^"1.E W !,"Jumping not allowed." G PATIENT "RTN","ACKQAS",54,0) G:$D(DTOUT) DIV "RTN","ACKQAS",55,0) I X="^" G DIV "RTN","ACKQAS",56,0) I Y<0 W !,"This is a required response. Enter '^' to exit" G PATIENT "RTN","ACKQAS",57,0) S (ACKPAT,DFN)=+Y "RTN","ACKQAS",58,0) S ACKDFN=DFN "RTN","ACKQAS",59,0) ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT "RTN","ACKQAS",60,0) S ACKOUT=0 "RTN","ACKQAS",61,0) D CHKDTH "RTN","ACKQAS",62,0) I ACKOUT=1 S ACKOUT=0 G PATIENT "RTN","ACKQAS",63,0) ;; END ACKQ*3*10 "RTN","ACKQAS",64,0) ; Check to see if Patient has a Primary Eligibility "RTN","ACKQAS",65,0) I '$$ELIGCHK^ACKQASU W !!,"DATA ERROR : Patient has no Primary Eligibility defined on the Patient File.",!,"This requires updating before QUASAR processing can commence.",! D VEXIT G DIV "RTN","ACKQAS",66,0) ; "RTN","ACKQAS",67,0) ; check for duplicate visits (same date/same patient) allow user to select one "RTN","ACKQAS",68,0) S ACKVSEL=$$DUPCHK^ACKQASU1(ACKPAT,ACKVD) G:ACKVSEL=-1 DIV "RTN","ACKQAS",69,0) S (DA,ACKY)=ACKVSEL ; either 0 (no visit selected) or selected visit ien "RTN","ACKQAS",70,0) ; "RTN","ACKQAS",71,0) S (ACKFLG1,ACKFLG2)=0 I DA D I (ACKFLG1)!(ACKFLG2) D VEXIT G VISIT "RTN","ACKQAS",72,0) .; Compare clinic location/stop code of selected visit with "RTN","ACKQAS",73,0) .; original clinic location/stop code. "RTN","ACKQAS",74,0) .S ACKESITE=$P($G(^ACK(509850.6,ACKY,0)),U,6),ACKECSC=$P($G(^ACK(509850.6,ACKY,2)),U) "RTN","ACKQAS",75,0) .I ACKESITE'=ACKCLIN S ACKFLG1=1 "RTN","ACKQAS",76,0) .I ACKECSC'=ACKCSC S ACKFLG2=1 "RTN","ACKQAS",77,0) .I (ACKFLG1)!(ACKFLG2) K DA D "RTN","ACKQAS",78,0) ..W !!,"The "_$S(ACKFLG1:"clinic location",1:"clinic stop code")_" for the selected appointment does not match",!,"the current "_$S(ACKFLG1:"clinic location",1:"clinic stop code")_". Transaction not allowed.",! "RTN","ACKQAS",79,0) ; "RTN","ACKQAS",80,0) ; Get PCE flag - 1 if division set to send to PCE else 0 "RTN","ACKQAS",81,0) S ACKPCE=$$PCE^ACKQUTL4(ACKDIV,ACKVD) "RTN","ACKQAS",82,0) ; "RTN","ACKQAS",83,0) ; Existing A&SP Patient "RTN","ACKQAS",84,0) I DA D EDIT^ACKQAS5 G VISIT "RTN","ACKQAS",85,0) ; "RTN","ACKQAS",86,0) ; New visit "RTN","ACKQAS",87,0) K DD,DO,DA,D0 "RTN","ACKQAS",88,0) S ACKVISIT="NEW",ACKVTME="" ; indicates this is a new visit "RTN","ACKQAS",89,0) ; "RTN","ACKQAS",90,0) ; If PCE interface not on skip to Call Template logic "RTN","ACKQAS",91,0) I 'ACKPCE S ACKVTME="" G FILE "RTN","ACKQAS",92,0) ; "RTN","ACKQAS",93,0) PCE ; Select a PCE visit "RTN","ACKQAS",94,0) ; "RTN","ACKQAS",95,0) ; Run function to check if there is a PCE visit for today "RTN","ACKQAS",96,0) I '$$PCEVST1^ACKQASU1(ACKVD,ACKPAT,ACKCLIN) G APPMNT "RTN","ACKQAS",97,0) ; "RTN","ACKQAS",98,0) ; As PCE visits must exist on the visit date run the API that displays "RTN","ACKQAS",99,0) ; them and prompts the user to either select one or add a new visit. "RTN","ACKQAS",100,0) S ACKPCENO=$$VISITLST^PXAPI(ACKPAT,ACKVD,ACKVD,ACKCLIN,"APO","","A") "RTN","ACKQAS",101,0) I ACKPCENO="-1" G DIV ; Go back to Division prompt if '^' entered "RTN","ACKQAS",102,0) S ACKVTME="" "RTN","ACKQAS",103,0) ; I ACKPCENO="A" 'ADD' selected user wishes to create new visit "RTN","ACKQAS",104,0) I ACKPCENO'="A" G FILE "RTN","ACKQAS",105,0) ; "RTN","ACKQAS",106,0) APPMNT ; Check for any appointments for the patient on this date. "RTN","ACKQAS",107,0) S VASD("C",ACKCLIN)="",VASD("T")=ACKVD,VASD("F")=ACKVD "RTN","ACKQAS",108,0) S VASD("W")="129" "RTN","ACKQAS",109,0) K ^UTILITY("VASD",$J) D SDA^VADPT "RTN","ACKQAS",110,0) I '$D(^UTILITY("VASD",$J)) G FILE ; If no appointments goto PCE check "RTN","ACKQAS",111,0) ; "RTN","ACKQAS",112,0) ; Displays headings and appointments "RTN","ACKQAS",113,0) ; "RTN","ACKQAS",114,0) D DISP^ACKQASU "RTN","ACKQAS",115,0) ; "RTN","ACKQAS",116,0) ; User is prompted to choose or create a new visit. "RTN","ACKQAS",117,0) ; "RTN","ACKQAS",118,0) APPMNT1 S ACKNUM=$O(^UTILITY("VASD",$J,""),-1) "RTN","ACKQAS",119,0) S DIR("A")=" Select Appointment (1-"_ACKNUM_") or (N)ew Visit " "RTN","ACKQAS",120,0) S DIR("B")=1 "RTN","ACKQAS",121,0) S DIR("?")=" Select number on left of the list or 'N' for New Visit" "RTN","ACKQAS",122,0) S DIR(0)="F^1:2^S:X=""n"" X=""N"" K:X'=""N""&((+X<1)!(+X>ACKNUM)) X" "RTN","ACKQAS",123,0) D ^DIR K DIR,ACKNUM "RTN","ACKQAS",124,0) I X?1"^"1.E W !,"Jumping not allowed." G APPMNT1 "RTN","ACKQAS",125,0) G:$D(DIRUT) DIV ; Go back to division if '^' entered. "RTN","ACKQAS",126,0) ; "RTN","ACKQAS",127,0) I X'="N"&(X'="n") S X=+X,ACKVTME=$P(^UTILITY("VASD",$J,X,"I"),U,1),ACKVTME=$P(ACKVTME,".",2),ACKAPMNT=1 "RTN","ACKQAS",128,0) K ^UTILITY("VASD",$J) "RTN","ACKQAS",129,0) ; "RTN","ACKQAS",130,0) FILE ; Set up dummy record and run input template "RTN","ACKQAS",131,0) ; "RTN","ACKQAS",132,0) ; If Appointment Time is not yet known, but a PCE Visit was selected, get the time "RTN","ACKQAS",133,0) I ACKVTME="",ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D "RTN","ACKQAS",134,0) . S ACKVTME=$$GETPCETM^ACKQASU(ACKPCENO),ACKVTME=$P($P(ACKVTME,U,1),".",2) "RTN","ACKQAS",135,0) . I 'ACKVTME S ACKVTME="" Q "RTN","ACKQAS",136,0) ; "RTN","ACKQAS",137,0) I ACKPCE,$G(ACKAPMNT)'=1,'$$ACKAPMNT^ACKQASU7(ACKVD,ACKVTME,ACKCLIN,ACKPAT) D VEXIT,HEADING G VISIT "RTN","ACKQAS",138,0) K ACKAPMNT "RTN","ACKQAS",139,0) ; "RTN","ACKQAS",140,0) ; Check to see if entry is on 'APCE' cross ref. if so either return to "RTN","ACKQAS",141,0) ; Division prompt or null out appointment time variable. "RTN","ACKQAS",142,0) I ACKVTME'="",$D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)) D I 'ACKQCHK D UNLOCK,VEXIT,HEADING G VISIT "RTN","ACKQAS",143,0) . S ACKQCHK=$$DUPEDATA^ACKQASU(ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME) "RTN","ACKQAS",144,0) . I 'ACKQCHK Q "RTN","ACKQAS",145,0) . ; user has decided to continue, so TIME is deleted and PCE VISIT is deleted "RTN","ACKQAS",146,0) . ; this ensures that the visit is treated as brand new when sent to PCE "RTN","ACKQAS",147,0) . S ACKVTME="" ; time "RTN","ACKQAS",148,0) . S ACKPCENO="" ; pce visit ien "RTN","ACKQAS",149,0) ; "RTN","ACKQAS",150,0) ; create new visit entry "RTN","ACKQAS",151,0) ; "RTN","ACKQAS",152,0) S DIC="^ACK(509850.6,",DIC(0)="L",DLAYGO=509850.6,ACKLAYGO="" "RTN","ACKQAS",153,0) S X=ACKVD D FILE^DICN,CHKDT ; File a dummy record prior to template "RTN","ACKQAS",154,0) S ACKVIEN=+$P(Y,U,1) ; Get visit IEN from Y value. "RTN","ACKQAS",155,0) ; "RTN","ACKQAS",156,0) K ACKARR "RTN","ACKQAS",157,0) S ACKARR(509850.6,ACKVIEN_",",2.6)=ACKCLIN "RTN","ACKQAS",158,0) S ACKARR(509850.6,ACKVIEN_",",60)=ACKDIV "RTN","ACKQAS",159,0) I +ACKVTME S ACKARR(509850.6,ACKVIEN_",",55)="."_ACKVTME ; file time if known "RTN","ACKQAS",160,0) I +$G(ACKPCENO)'=0 S ACKARR(509850.6,ACKVIEN_",",125)=ACKPCENO ; file PCE number if one selected "RTN","ACKQAS",161,0) D STOP S ACKARR(509850.6,ACKVIEN_",",4)=ACKCSC ; file visit stop (required by COPYPCE) "RTN","ACKQAS",162,0) D FILE^DIE("","ACKARR") "RTN","ACKQAS",163,0) ; "RTN","ACKQAS",164,0) ; Lock the record "RTN","ACKQAS",165,0) L +^ACK(509850.6,ACKVIEN) "RTN","ACKQAS",166,0) ; "RTN","ACKQAS",167,0) ; Write away any derived PCE values to visit record "RTN","ACKQAS",168,0) I ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D I +ACKERR D DEL,UNLOCK,VEXIT,HEADING G VISIT "RTN","ACKQAS",169,0) . S ACKERR=$$COPYPCE^ACKQASU4(ACKVIEN,ACKPCENO) "RTN","ACKQAS",170,0) . ; if error found, display and reset ACKERR according to whether the "RTN","ACKQAS",171,0) . ; user wants to continue (SHOWPCE returns 1=exit,0=continue) "RTN","ACKQAS",172,0) . I +ACKERR S ACKERR=$$SHOWPCE^ACKQASU7($NA(^TMP("ACKQASU4",$J,"COPYPCE","ERROR"))) "RTN","ACKQAS",173,0) ; "RTN","ACKQAS",174,0) ; "RTN","ACKQAS",175,0) TPLATE ; Call template "RTN","ACKQAS",176,0) S DIE="^ACK(509850.6,",(DA,ACKDA)=ACKVIEN,DR="[ACKQAS VISIT ENTRY]" D ^DIE "RTN","ACKQAS",177,0) ; "RTN","ACKQAS",178,0) K ACKREQ "RTN","ACKQAS",179,0) I $G(ACKLOSS)'="",$$AUDIO^ACKQUTL4 D UTLAUD^ACKQASU2 "RTN","ACKQAS",180,0) S ACKQTST=$$POST^ACKQASU2(ACKVIEN) I 'ACKQTST S ACKDFN=DFN G TPLATE "RTN","ACKQAS",181,0) I ACKPCE,ACKQTST=1 I '$$PCESEND^ACKQASU3(ACKVIEN) S ACKDFN=DFN G TPLATE "RTN","ACKQAS",182,0) D UNLOCK,VEXIT,HEADING G VISIT "RTN","ACKQAS",183,0) ; "RTN","ACKQAS",184,0) VEXIT ; Kill off variables at end of processing "RTN","ACKQAS",185,0) ; "RTN","ACKQAS",186,0) D KILL^ACKQASU "RTN","ACKQAS",187,0) D KILL^%ZISS "RTN","ACKQAS",188,0) Q "RTN","ACKQAS",189,0) ; "RTN","ACKQAS",190,0) AOA ; COMPUTE AGE ON APPOINTMENT DATE "RTN","ACKQAS",191,0) N DFN,VA,VADM,VAERR,X1,X2 S DFN=$P(^ACK(509850.6,D0,0),U,2),X1=$P(^(0),U) D DEM^VADPT S X2=+VADM(3),X=X1-X2\10000 "RTN","ACKQAS",192,0) Q "RTN","ACKQAS",193,0) ; "RTN","ACKQAS",194,0) CHKDT ; "RTN","ACKQAS",195,0) S ACKMON=$E(X,1,5) S ACKGEN=$S($D(^ACK(509850.7,ACKMON,0)):^(0),1:"") "RTN","ACKQAS",196,0) Q:'$L(ACKGEN) I $P(ACKGEN,U,4) W !!,$C(7),"Capitation data for that time period has already been compiled.",!,"To insure proper credit for this visit, please make sure the capitation",!,"data is regenerated.",! "RTN","ACKQAS",197,0) Q "RTN","ACKQAS",198,0) ; "RTN","ACKQAS",199,0) SITE ; "RTN","ACKQAS",200,0) S DIR(0)="P^ACK(509850.8,1,1,:AEMQ",DA(1)=1 "RTN","ACKQAS",201,0) S DIR("A")="Select Clinic Location" "RTN","ACKQAS",202,0) S DIR("?")="Choose the clinic location that should be associated with these visits." "RTN","ACKQAS",203,0) D ^DIR K DIR S:'$D(DIRUT) ACKSITE=+Y Q:$D(DIRUT) "RTN","ACKQAS",204,0) ; "RTN","ACKQAS",205,0) STOP ; "RTN","ACKQAS",206,0) S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,8,"I") "RTN","ACKQAS",207,0) S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1)) "RTN","ACKQAS",208,0) S ACKCSC="" "RTN","ACKQAS",209,0) I ACKCSC(1)=203 S ACKCSC="A" "RTN","ACKQAS",210,0) I ACKCSC(1)=204 S ACKCSC="S" "RTN","ACKQAS",211,0) I ACKCSC="" D "RTN","ACKQAS",212,0) . S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,2503,"I") "RTN","ACKQAS",213,0) . S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1)) "RTN","ACKQAS",214,0) . I ACKCSC(1)=203 S ACKCSC="AT" "RTN","ACKQAS",215,0) . I ACKCSC(1)=204 S ACKCSC="ST" "RTN","ACKQAS",216,0) ; "RTN","ACKQAS",217,0) K ACKCSCP "RTN","ACKQAS",218,0) Q "RTN","ACKQAS",219,0) ; "RTN","ACKQAS",220,0) ; "RTN","ACKQAS",221,0) UNLOCK ; Unlock Locked record "RTN","ACKQAS",222,0) L "RTN","ACKQAS",223,0) Q "RTN","ACKQAS",224,0) ; "RTN","ACKQAS",225,0) HEADING ; "RTN","ACKQAS",226,0) W @IOF "RTN","ACKQAS",227,0) W !,"This option is used to enter new A&SP clinic visits. Existing clinic",!,"visits should be updated with the Edit an Existing Visit option.",! "RTN","ACKQAS",228,0) Q "RTN","ACKQAS",229,0) ; "RTN","ACKQAS",230,0) DEL W !!,$C(7),"<>",!! "RTN","ACKQAS",231,0) S DIK="^ACK(509850.6,",DA=ACKVIEN D ^DIK "RTN","ACKQAS",232,0) Q "RTN","ACKQAS",233,0) ; "RTN","ACKQAS",234,0) CHKDTH ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT "RTN","ACKQAS",235,0) N I,X,Y,ACKDIRUT,ACK,VA,VADM,VAERR "RTN","ACKQAS",236,0) D DEM^VADPT "RTN","ACKQAS",237,0) S ACK(4)="" "RTN","ACKQAS",238,0) I VADM(6)'="" D "RTN","ACKQAS",239,0) .S Y=$P(VADM(6),"^",2) "RTN","ACKQAS",240,0) .X ^DD("DD") "RTN","ACKQAS",241,0) .S ACK(4)="[PATIENT DIED ON "_$P(Y,"@")_"]" "RTN","ACKQAS",242,0) I ACK(4)'="" W !!,ACK(4),! S ACKOUT=1 "RTN","ACKQAS",243,0) ;; END ACKQ*3*10 "RTN","ACKQAS",244,0) Q "RTN","ACKQASU") 0^2^B21282151^B21284718 "RTN","ACKQASU",1,0) ACKQASU ;HCIOFO/BH-New/Edit Visit Utilities ; 04/01/99 "RTN","ACKQASU",2,0) ;;3.0;QUASAR;**8,15**;Feb 11, 2000;Build 2 "RTN","ACKQASU",3,0) ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. "RTN","ACKQASU",4,0) ; "RTN","ACKQASU",5,0) ELIGCHK() ; Checks to see if there is a Primary Eligibility (which there "RTN","ACKQASU",6,0) ; always should be) if there's not (i.e. data error) pass back zero. "RTN","ACKQASU",7,0) ; "RTN","ACKQASU",8,0) N ACKFLG "RTN","ACKQASU",9,0) D ELIG^VADPT S:VAEL(1)="" ACKFLG="0" S:VAEL(1)'="" ACKFLG=1 "RTN","ACKQASU",10,0) K VAEL "RTN","ACKQASU",11,0) Q ACKFLG "RTN","ACKQASU",12,0) ; "RTN","ACKQASU",13,0) DISP ; Displays headings and Patient Appointments "RTN","ACKQASU",14,0) ; "RTN","ACKQASU",15,0) ; CLEAR SCREEN WRITE FROM TOP "RTN","ACKQASU",16,0) D ENS^%ZISS "RTN","ACKQASU",17,0) W @IOF "RTN","ACKQASU",18,0) ; Get date for display "RTN","ACKQASU",19,0) D NOW^%DTC S Y=% D DD^%DT S ACKDDT1=$TR(Y,"@"," "),ACKDDT2=X "RTN","ACKQASU",20,0) S ACKSSN=$$GET1^DIQ(2,ACKPAT,".09") "RTN","ACKQASU",21,0) W " - ",IOUON,"APPOINTMENT LIST",IOUOFF," -",! "RTN","ACKQASU",22,0) W !," Name : "_$$GET1^DIQ(2,ACKPAT,".01") "RTN","ACKQASU",23,0) W ?38,"SSN : ",$E(ACKSSN,1,3)_"-"_$E(ACKSSN,4,5)_"-"_$E(ACKSSN,6,9) "RTN","ACKQASU",24,0) W !," Date : "_$E(ACKDDT2,4,5)_"/"_$E(ACKDDT2,6,7)_"/"_$E(ACKDDT2,2,3) "RTN","ACKQASU",25,0) W ?38,"Clinic : "_$$GET1^DIQ(44,ACKCLIN,.01) "RTN","ACKQASU",26,0) W !,IOUON," ",IOUOFF "RTN","ACKQASU",27,0) ; "RTN","ACKQASU",28,0) ; "RTN","ACKQASU",29,0) W !!," ",IOUON,"Appt Date/Time",IOUOFF," ",IOUON,"Status",IOUOFF," ",IOUON,"Appointment Type",IOUOFF "RTN","ACKQASU",30,0) K ACKDDT1,ACKDDT2,ACKSSN "RTN","ACKQASU",31,0) ; "RTN","ACKQASU",32,0) S ACKK3="" "RTN","ACKQASU",33,0) F S ACKK3=$O(^UTILITY("VASD",$J,ACKK3)) Q:ACKK3="" D "RTN","ACKQASU",34,0) . S ACKSTRIN=^UTILITY("VASD",$J,ACKK3,"E") "RTN","ACKQASU",35,0) . W !!," "_ACKK3_"." "RTN","ACKQASU",36,0) . W ?4,$P($P(ACKSTRIN,U,1),"@",1)_" "_$P($P(ACKSTRIN,U,1),"@",2) "RTN","ACKQASU",37,0) . W ?23,$S($P(ACKSTRIN,U,3)'="":$P(ACKSTRIN,U,3),1:"NO ACTION TAKEN") "RTN","ACKQASU",38,0) . W ?49,$P(ACKSTRIN,U,4) "RTN","ACKQASU",39,0) W !!! "RTN","ACKQASU",40,0) Q "RTN","ACKQASU",41,0) ; "RTN","ACKQASU",42,0) KILL ; Kill off values at end of processing "RTN","ACKQASU",43,0) K ACK0,ACK2,ACKCAT,ACKCD,ACKCDN,ACKCLN,ACKCNT,ACKCP,ACKDA,ACKDC,ACKDUP "RTN","ACKQASU",44,0) K ACKDUPN,ACKECSC,ACKESITE,ACKFLD,ACKFLG1,ACKFLG2,ACKGEN,ACKI,ACKLAYGO "RTN","ACKQASU",45,0) K ACKMOD,ACKMON,ACKQCPS,ACKQCPT,ACKQRAW,ACKRAW,ACKREQ,ACKSEL,ACKSTF "RTN","ACKQASU",46,0) K ACKSIG,ACKTM,ACKVD,ACKY,ACKDEF,ACKDIVN,ACKCSC,ACKCPNO,ACKCLNO,ACKCLIN "RTN","ACKQASU",47,0) K ACKL1,ACKL2,ACKL3,ACKL4,ACKR1,ACKR2,ACKR3,ACKR4,ACKTITL,%,%DT,%I,%X "RTN","ACKQASU",48,0) K %Y,C,D0,DA,DFN,DIC,DIE,DIK,DIRUT,DLAYGO,DR,DTOUT,DUOUT,I,J,VA,VADM "RTN","ACKQASU",49,0) K VAERR,X,X1,X4,Y,ACKELIG,ACKIEN,ACKK2,ACKLAMD,ACKLOSS,ACKN,ACKPCE "RTN","ACKQASU",50,0) K ACKVISIT,ACKPAT,ACKVIEN,ACKDIV,ACLCLIN,ACKCHK,ACKVIEN,ACKAO,ACKSC "RTN","ACKQASU",51,0) K CLINVAR,DIVARR,ACKRAD,ACKENV,ACKPROV,ACKDIAGD,ACKCPTDS,ACKDIRUT "RTN","ACKQASU",52,0) K ACKPCENO,VSAD,DIVARR,DIV,CLINVARR,ACKTME,ACKSCR,ACKELGCT,ACKELG1 "RTN","ACKQASU",53,0) K ACKTRGT,ACKDVN,ACKACKBA,ACKAUDIO,ACKATS,ACKQUIT,ACKMSG,ACKQTST "RTN","ACKQASU",54,0) K ACKQSER,ACKQORG,ACKQIR,ACKQECON,ACKAPMNT,ICPTVDT,ICDVDT "RTN","ACKQASU",55,0) Q "RTN","ACKQASU",56,0) ; "RTN","ACKQASU",57,0) ; "RTN","ACKQASU",58,0) DC ; CHECK OUT DIAGNOSTIC CONDITION - ENTER IF NEEDED "RTN","ACKQASU",59,0) N ACKY "RTN","ACKQASU",60,0) Q:$D(^ACK(509850.2,DFN,1,"B",ACKDC)) "RTN","ACKQASU",61,0) S ACKY=Y D DEM^VADPT S Y=ACKY,X=$$GET1^DIQ(80,ACKDC,.01),ACKLN=$P(VADM(1),","),ACKSX=$P(VADM(5),U) "RTN","ACKQASU",62,0) I $G(ACKBGRD)'="1" D "RTN","ACKQASU",63,0) . W !!,X," ",$$DIAGTXT^ACKQUTL8(ACKDC,ACKVD) "RTN","ACKQASU",64,0) . W !,"We have no previous record of diagnostic condition ",X," for ",$S(ACKSX="F":"Ms.",1:"Mr.")," ",ACKLN,"." D ADCODE "RTN","ACKQASU",65,0) . W !,"Ok, I've added this code to ",$S(ACKSX="F":"her",1:"his")," permanent record !",! "RTN","ACKQASU",66,0) I $G(ACKBGRD)=1 D ADCODE "RTN","ACKQASU",67,0) K ACK0,ACKLN,ACKSX,VA,VADM,VAERR,X Q "RTN","ACKQASU",68,0) ; "RTN","ACKQASU",69,0) ADCODE ; Adds ICD to permanent record. "RTN","ACKQASU",70,0) N D,D0,D1,DA,DB,DC,DD,DDTM,DE,DF,DG,DH,DI,DIC,DIE,DIEL,DIFLD,DIOV,DIP,DJ,DK,DL,DM,DN,DO,DP,DQ,DR,DU,DV,DW,DXS,DZ,I,Y ;we're calling this from FM "RTN","ACKQASU",71,0) L +^ACK(509850.2,DFN,1,0) S (DIC,DIE)="^ACK(509850.2,"_DFN_",1,",DIC(0)="L",DLAYGO=509850.2,ACKLAYGO="" "RTN","ACKQASU",72,0) S DIC("P")=$P(^DD(509850.2,2,0),"^",2),DA(1)=DFN,X=ACKDC D FILE^DICN Q:Y<0 S DA=+Y,DR="2;1///"_ACKVD D ^DIE "RTN","ACKQASU",73,0) L -^ACK(509850.2,DFN,1,0) Q "RTN","ACKQASU",74,0) ; "RTN","ACKQASU",75,0) Q "RTN","ACKQASU",76,0) ; "RTN","ACKQASU",77,0) GETPCETM(ACKPCENO) ; get appointment time from a PCE Visit ien "RTN","ACKQASU",78,0) ; inputs:- ACKPCENO - PCE Visit ien (from ^AUPNVSIT) "RTN","ACKQASU",79,0) ; returned :- 0^ - error (visit not found) "RTN","ACKQASU",80,0) ; '.nnnnnn^' - time portion of PCE visit date/time "RTN","ACKQASU",81,0) N ACKDATE,ACKTM "RTN","ACKQASU",82,0) K ^TMP("PXKENC",$J) "RTN","ACKQASU",83,0) D ENCEVENT^PXAPI(ACKPCENO) "RTN","ACKQASU",84,0) S ACKDATE=$P($G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,0)),U,1) "RTN","ACKQASU",85,0) S ACKTM=$S(ACKDATE="":0,1:ACKDATE#1) "RTN","ACKQASU",86,0) K ^TMP("PXKENC",$J) "RTN","ACKQASU",87,0) Q ACKTM_U "RTN","ACKQASU",88,0) ; "RTN","ACKQASU",89,0) DUPEDATA(ACKPAT,ACKCLIN,ACKVD,ACKTM) ; If an appointment or PCE visit has been selected for a visit "RTN","ACKQASU",90,0) ; which is at the same time, for the same patient, on the same day "RTN","ACKQASU",91,0) ; within the same clinic this processing is run. "RTN","ACKQASU",92,0) ; inputs:- ACKPAT - patient ien "RTN","ACKQASU",93,0) ; ACKCLIN - clinic ien "RTN","ACKQASU",94,0) ; ACKVD - visit date (internal) "RTN","ACKQASU",95,0) ; ACKTM - appointment time (.NNN - internal) "RTN","ACKQASU",96,0) W !!?4,"ERROR - A visit already exists in QUASAR with the following details..",! "RTN","ACKQASU",97,0) W !?7,"Visit Date: ",$$DATE(ACKVD)," Appointment Time: ",$$TIME(ACKTM) "RTN","ACKQASU",98,0) W !?7," Clinic: ",$$GET1^DIQ(44,ACKCLIN_",",.01,"E") "RTN","ACKQASU",99,0) W !?7," Patient: ",$$GET1^DIQ(509850.2,ACKPAT_",",.01,"E") "RTN","ACKQASU",100,0) W !!?4,"If you choose to continue you must enter a different Appointment Time." "RTN","ACKQASU",101,0) ; "RTN","ACKQASU",102,0) ; W !!,"There is already an entry within Quasar for this Patient, within the same" "RTN","ACKQASU",103,0) ; W !,"Clinic, on the same date at the same time." "RTN","ACKQASU",104,0) ; W !!,"Enter '^' to terminate and quit back to the Division prompt" "RTN","ACKQASU",105,0) ; W !,"or to continue." "RTN","ACKQASU",106,0) W ! "RTN","ACKQASU",107,0) K DIR S DIR(0)="E" D ^DIR K DIR ; Return to Continue '^' to Exit "RTN","ACKQASU",108,0) I X="^" Q 0 "RTN","ACKQASU",109,0) Q 1 "RTN","ACKQASU",110,0) ; "RTN","ACKQASU",111,0) DATE(ACKDATE) ; convert ACKDATE to external format "RTN","ACKQASU",112,0) S Y=ACKDATE D DD^%DT "RTN","ACKQASU",113,0) Q Y "RTN","ACKQASU",114,0) TIME(ACKTIME) ; convert Time to external format "RTN","ACKQASU",115,0) Q $$FMT^ACKQUTL6(ACKTIME,1) "RTN","ACKQUTL2") 0^3^B36429038^B37709691 "RTN","ACKQUTL2",1,0) ACKQUTL2 ;AUG/JLTP BIR/PTD HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/96 10:03 ] "RTN","ACKQUTL2",2,0) ;;3.0;QUASAR;**15**;Feb 11, 2000;Build 2 "RTN","ACKQUTL2",3,0) ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified. "RTN","ACKQUTL2",4,0) ; "RTN","ACKQUTL2",5,0) ; "RTN","ACKQUTL2",6,0) DIVLIST(ACKTYP,ACKTXT) ; list on screen all the Divisions on the Site Parameter File "RTN","ACKQUTL2",7,0) ; optional ACKTYP = type of list 1=Active only, 0 (default) = all "RTN","ACKQUTL2",8,0) ; optional ACKTXT = preceding message "RTN","ACKQUTL2",9,0) N ACKFROM,ACKFDA,ACKMSG,ACKSCRN,DIWL,DIWR,DIWF,X,Y,I,DA,ACKCT "RTN","ACKQUTL2",10,0) S ACKFROM="",ACKTYP=$S(+$G(ACKTYP)=1:1,1:0) "RTN","ACKQUTL2",11,0) ; set up the screen if only active divisions are to be listed "RTN","ACKQUTL2",12,0) S ACKSCRN=$S(ACKTYP=1:"I $P(^(0),U,2)=""A""",1:"") "RTN","ACKQUTL2",13,0) ; call fileman to retrieve the Divisions "RTN","ACKQUTL2",14,0) D LIST^DIC(509850.83,",1,",".01;.02","","",.ACKFROM,"","",ACKSCRN,"","ACKFDA","ACKMSG") "RTN","ACKQUTL2",15,0) ; get count of number of Divisions "RTN","ACKQUTL2",16,0) S ACKCT=$P(ACKFDA("DILIST",0),U,1) "RTN","ACKQUTL2",17,0) ; determine the text header "RTN","ACKQUTL2",18,0) I ACKCT=0,ACKTYP=0 S ACKTXT=" No Divisions have been set up." "RTN","ACKQUTL2",19,0) I ACKCT=0,ACKTYP=1 S ACKTXT=" There are no Active Divisions on file." "RTN","ACKQUTL2",20,0) I $G(ACKTXT)="" D "RTN","ACKQUTL2",21,0) . I ACKCT>0 S ACKTXT=" The following Divisions have been set up..." "RTN","ACKQUTL2",22,0) ; "RTN","ACKQUTL2",23,0) ; the following section uses DIWP & DIWW to format and output the text "RTN","ACKQUTL2",24,0) S DIWL=5,DIWR=75,DIWF="" "RTN","ACKQUTL2",25,0) S X="|SETTAB(10,40)| " D ^DIWP "RTN","ACKQUTL2",26,0) S X=" " D ^DIWP ;blank line! "RTN","ACKQUTL2",27,0) S X=ACKTXT D ^DIWP "RTN","ACKQUTL2",28,0) ; now output each Division "RTN","ACKQUTL2",29,0) F ACK=1:1:ACKCT D "RTN","ACKQUTL2",30,0) . ; print division name "RTN","ACKQUTL2",31,0) . S X=" |TAB|"_$E(ACKFDA("DILIST",1,ACK),1,25) "RTN","ACKQUTL2",32,0) . ; if all divisions to be printed then also print the status "RTN","ACKQUTL2",33,0) . I ACKTYP=0 S X=X_"|TAB|"_$$MC(ACKFDA("DILIST","ID",ACK,.02)) "RTN","ACKQUTL2",34,0) . D ^DIWP "RTN","ACKQUTL2",35,0) ; now write to the screen "RTN","ACKQUTL2",36,0) D ^DIWW "RTN","ACKQUTL2",37,0) ; "RTN","ACKQUTL2",38,0) ; end "RTN","ACKQUTL2",39,0) Q "RTN","ACKQUTL2",40,0) ; "RTN","ACKQUTL2",41,0) MC(X) ; convert X to mixed case (1st upper, remainder lower) "RTN","ACKQUTL2",42,0) N UP,LW S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LW="abcdefghijklmnopqrstuvwxyz" "RTN","ACKQUTL2",43,0) Q $TR($E(X),LW,UP)_$TR($E(X,2,999),UP,LW) "RTN","ACKQUTL2",44,0) ; "RTN","ACKQUTL2",45,0) ; "RTN","ACKQUTL2",46,0) DIV(ACKTYP,ACKDIV,ACKSTA) ; prompt user for an A&SP Division "RTN","ACKQUTL2",47,0) ; where ACKTYP can be 1=one div, 2=many, 3=many/all "RTN","ACKQUTL2",48,0) ; if ACTYPE>1 then ACKDIV must be passed in by reference "RTN","ACKQUTL2",49,0) ; and ACKSTA contains the required status of the Division "RTN","ACKQUTL2",50,0) ; so if ACKSTA="A" then only active divisions may be chosen "RTN","ACKQUTL2",51,0) ; if ACKSTA="I" then only inactive divisions may be chosen "RTN","ACKQUTL2",52,0) ; if ACKSTA="AI" or "IA" then either active or inactive may be "RTN","ACKQUTL2",53,0) ; chosen. If not passed then "A" is used as the default. "RTN","ACKQUTL2",54,0) ; ------------------------------------------------------------ "RTN","ACKQUTL2",55,0) ; function returns:- "RTN","ACKQUTL2",56,0) ; ACKDIV=a^b where a=no. divisions selected, and b=total "RTN","ACKQUTL2",57,0) ; available divisions. "RTN","ACKQUTL2",58,0) ; (if the user quits or times out then a=0) "RTN","ACKQUTL2",59,0) ; ACKDIV(x)=x^y^z where "RTN","ACKQUTL2",60,0) ; x=div ien on Med Cen Div file #40.8, "RTN","ACKQUTL2",61,0) ; y=div ien on Site Parameters #509850.83 "RTN","ACKQUTL2",62,0) ; and z=division name "RTN","ACKQUTL2",63,0) ; ------------------------------------------------------------ "RTN","ACKQUTL2",64,0) N DIVARR,ACKDIVN,ACKN,ACKDEF,ACKDFLT,ACKIEN,ACKX "RTN","ACKQUTL2",65,0) K ACKDIV "RTN","ACKQUTL2",66,0) ; initialise selected Division "RTN","ACKQUTL2",67,0) S ACKDIV="" "RTN","ACKQUTL2",68,0) ; "RTN","ACKQUTL2",69,0) ; check parameter has been passed in "RTN","ACKQUTL2",70,0) I "1/2/3"'[+$G(ACKTYP) G DIVX "RTN","ACKQUTL2",71,0) ; "RTN","ACKQUTL2",72,0) ; get list of divisions "RTN","ACKQUTL2",73,0) D GETDIV^ACKQRU(.DIVARR,$G(ACKSTA),"U") "RTN","ACKQUTL2",74,0) ; "RTN","ACKQUTL2",75,0) ; no Divisions exist "RTN","ACKQUTL2",76,0) I DIVARR<1 S ACKDIV=0 G DIVX "RTN","ACKQUTL2",77,0) ; "RTN","ACKQUTL2",78,0) ; only one Division exists "RTN","ACKQUTL2",79,0) I DIVARR=1 D G DIVX "RTN","ACKQUTL2",80,0) . S ACKDIV="1^1",ACKDIV($P(DIVARR(1,1),U,1))=$P(DIVARR(1,1),U,1,3)_U "RTN","ACKQUTL2",81,0) ; "RTN","ACKQUTL2",82,0) ; get last Division selected by the user (spacebar recall) "RTN","ACKQUTL2",83,0) S ACKDEF=$$FIND1^DIC(509850.83,",1,",""," ") "RTN","ACKQUTL2",84,0) S ACKDEF=$S(ACKDEF:$$EXTERNAL^DILFD(509850.83,".01","",ACKDEF),1:"") "RTN","ACKQUTL2",85,0) S ACKDEF=$$UC(ACKDEF) ; convert to uppercase "RTN","ACKQUTL2",86,0) I ACKDEF'="",'$D(DIVARR(2,ACKDEF)) S ACKDEF="" "RTN","ACKQUTL2",87,0) S ACKDFLT=$S(ACKDEF="":"",1:"2^"_ACKDEF) "RTN","ACKQUTL2",88,0) ; "RTN","ACKQUTL2",89,0) ; multiple divisions exist, only one required. "RTN","ACKQUTL2",90,0) I ACKTYP=1,DIVARR>1 D G DIVX "RTN","ACKQUTL2",91,0) . D SELECT^ACKQSEL(1,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT) "RTN","ACKQUTL2",92,0) . ; get Division IEN "RTN","ACKQUTL2",93,0) . I $O(DIVARR(4,""))="" S ACKDIV="0^"_DIVARR Q ; either quit or timed out "RTN","ACKQUTL2",94,0) . S ACKDIVN=$O(DIVARR(4,"")),ACKN=DIVARR(2,ACKDIVN) "RTN","ACKQUTL2",95,0) . S ACKIEN=$P(DIVARR(1,ACKN),U,1) "RTN","ACKQUTL2",96,0) . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall "RTN","ACKQUTL2",97,0) . S ACKDIV="1^"_DIVARR "RTN","ACKQUTL2",98,0) . S ACKDIV(ACKIEN)=$P(DIVARR(1,ACKN),U,1,3)_U "RTN","ACKQUTL2",99,0) ; "RTN","ACKQUTL2",100,0) ; multiple divisions exist, user may select one/many or ALL. "RTN","ACKQUTL2",101,0) I ACKTYP>1,DIVARR>1 D G DIVX "RTN","ACKQUTL2",102,0) . D SELECT^ACKQSEL(ACKTYP,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT) "RTN","ACKQUTL2",103,0) . ; get Division IEN "RTN","ACKQUTL2",104,0) . I $G(DIVARR(4))'="" S ACKDIV="0^"_DIVARR Q ;either quit or timed out "RTN","ACKQUTL2",105,0) . S ACKDIV=U_DIVARR "RTN","ACKQUTL2",106,0) . S ACKX="" F S ACKX=$O(DIVARR(4,ACKX)) Q:ACKX="" D "RTN","ACKQUTL2",107,0) . . S $P(ACKDIV,U,1)=$P(ACKDIV,U,1)+1,ACKN=DIVARR(2,ACKX) "RTN","ACKQUTL2",108,0) . . S ACKDIV($P(DIVARR(1,ACKN),U,1))=$P(DIVARR(1,ACKN),U,1,3)_U "RTN","ACKQUTL2",109,0) . ; if only one selected then save for spacebar recall "RTN","ACKQUTL2",110,0) . I +$P(ACKDIV,U,1)=1 D "RTN","ACKQUTL2",111,0) . . S ACKIEN=$O(ACKDIV("")) Q:'ACKIEN "RTN","ACKQUTL2",112,0) . . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall "RTN","ACKQUTL2",113,0) ; "RTN","ACKQUTL2",114,0) DIVX ; end "RTN","ACKQUTL2",115,0) Q ACKDIV "RTN","ACKQUTL2",116,0) ; "RTN","ACKQUTL2",117,0) ; "RTN","ACKQUTL2",118,0) DIVHLP ; displays help text for the Division prompt "RTN","ACKQUTL2",119,0) N X,DIWL,DIWR,DIWF "RTN","ACKQUTL2",120,0) S DIWL=1,DIWR=80,DIWF="" "RTN","ACKQUTL2",121,0) S X=" " D ^DIWP "RTN","ACKQUTL2",122,0) S X=" Enter the name of a Division from the A&SP Site Parameters File." D ^DIWP "RTN","ACKQUTL2",123,0) S X=" Enter '??' to see a list of the available Divisions, '^' to exit." D ^DIWP "RTN","ACKQUTL2",124,0) D ^DIWW "RTN","ACKQUTL2",125,0) Q "RTN","ACKQUTL2",126,0) LEADROLE(ACKVIEN) ; determine lead role for a visit "RTN","ACKQUTL2",127,0) ; prior to version 3.0 all visits would be filed with a Lead Role "RTN","ACKQUTL2",128,0) ; entered by the user (either the primary clinician, secondary "RTN","ACKQUTL2",129,0) ; clinician or other prov). With ver 3.0 this field is no longer "RTN","ACKQUTL2",130,0) ; populated and the lead role is the primary provider, or if absent "RTN","ACKQUTL2",131,0) ; the secondary provider. In order to be backward compatible this "RTN","ACKQUTL2",132,0) ; function will check the lead role field first. If it contains a "RTN","ACKQUTL2",133,0) ; value then the visit must be pre-ver 3.0 and this code must be "RTN","ACKQUTL2",134,0) ; the lead role selected by the user. If the lead role field is "RTN","ACKQUTL2",135,0) ; empty then the visit must be post-ver 3.0 and so this function "RTN","ACKQUTL2",136,0) ; will return either the primary or secondary provider. "RTN","ACKQUTL2",137,0) N ACKSECV2,ACKTGT,ACKMSG,ACKLEAD,ACKIENS,ACKPRIM,ACKSCND,ACKSTUD,ACKMSG1,ACKTGT1 "RTN","ACKQUTL2",138,0) N ACK2 "RTN","ACKQUTL2",139,0) S ACKIENS=ACKVIEN_"," "RTN","ACKQUTL2",140,0) D GETS^DIQ(509850.6,ACKIENS,".25;.27;6","I","ACKTGT","ACKMSG") "RTN","ACKQUTL2",141,0) S ACKLEAD=ACKTGT(509850.6,ACKIENS,.27,"I") ; Lead role (Pre V.3.) "RTN","ACKQUTL2",142,0) I +ACKLEAD>0 Q +ACKLEAD "RTN","ACKQUTL2",143,0) S ACKPRIM=ACKTGT(509850.6,ACKIENS,6,"I") ; Primary clinician "RTN","ACKQUTL2",144,0) I +ACKPRIM>0 Q +ACKPRIM "RTN","ACKQUTL2",145,0) S ACKSECV2=ACKTGT(509850.6,ACKIENS,.25,"I") ; Pre V.3 Sec'dry clinician "RTN","ACKQUTL2",146,0) I +ACKSECV2>0 Q +ACKSECV2 "RTN","ACKQUTL2",147,0) ; "RTN","ACKQUTL2",148,0) D LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT1","ACKMSG1") "RTN","ACKQUTL2",149,0) S ACKSCND=$O(ACKTGT1("DILIST",1,"")) "RTN","ACKQUTL2",150,0) I ACKSCND'="" S ACKSCND=ACKTGT1("DILIST",1,ACKSCND) "RTN","ACKQUTL2",151,0) Q +ACKSCND ; First Secondary Provider V.3. "RTN","ACKQUTL2",152,0) ; "RTN","ACKQUTL2",153,0) ASPDIV(ACKDIV) ; returns true if ACKDIV is a valid ASP division "RTN","ACKQUTL2",154,0) N ACKTGT,ACKMSG,ACKFND "RTN","ACKQUTL2",155,0) ; look for the Division on the Site Parameters file "RTN","ACKQUTL2",156,0) D FIND^DIC(509850.83,",1,","","","`"_ACKDIV,1,"","","","ACKTGT","ACKMSG") "RTN","ACKQUTL2",157,0) ; get number found "RTN","ACKQUTL2",158,0) S ACKFND=$P($G(ACKTGT("DILIST",0)),U,1) "RTN","ACKQUTL2",159,0) Q (ACKFND=1) "RTN","ACKQUTL2",160,0) CLNDIV(ACKCLN) ; returns the ien of the division that the clinic is in. "RTN","ACKQUTL2",161,0) Q $$GET1^DIQ(44,ACKCLN_",",3.5,"I") "RTN","ACKQUTL2",162,0) ASPCLN(ACKCLN) ; returns true if ACKCLN is a valid clinic for ASP "RTN","ACKQUTL2",163,0) ; ACKCLN is the internal entry number from the hospital locations file "RTN","ACKQUTL2",164,0) ; true returned if stop code is 203-Audiology, 204-Speech "RTN","ACKQUTL2",165,0) ; if stop code is invalid then the credit stop code field must be either 203 or 204. "RTN","ACKQUTL2",166,0) N ACKSTOP,ACKCRDT,ACKSC "RTN","ACKQUTL2",167,0) ; get ien of stop code "RTN","ACKQUTL2",168,0) S ACKSTOP=$$GET1^DIQ(44,ACKCLN_",",8,"I") "RTN","ACKQUTL2",169,0) I ACKSTOP="" Q 0 ; bad clinic record "RTN","ACKQUTL2",170,0) ; get actual stop code "RTN","ACKQUTL2",171,0) S ACKSC=$$GET1^DIQ(40.7,ACKSTOP_",",1) "RTN","ACKQUTL2",172,0) ; exit "RTN","ACKQUTL2",173,0) I ACKSC=203 Q 1 ; audiology "RTN","ACKQUTL2",174,0) I ACKSC=204 Q 1 ; speech pathology "RTN","ACKQUTL2",175,0) ; get clinic credit stop code "RTN","ACKQUTL2",176,0) S ACKCRDT=$$GET1^DIQ(44,ACKCLN_",",2503,"I") "RTN","ACKQUTL2",177,0) I ACKCRDT="" Q 0 ; no credit stop code "RTN","ACKQUTL2",178,0) ; get actual stop code "RTN","ACKQUTL2",179,0) S ACKSC=$$GET1^DIQ(40.7,ACKCRDT_",",1) "RTN","ACKQUTL2",180,0) ; exit "RTN","ACKQUTL2",181,0) I ACKSC=203 Q 1 ; audiology "RTN","ACKQUTL2",182,0) I ACKSC=204 Q 1 ; speech pathology "RTN","ACKQUTL2",183,0) Q 0 ; any other value is invalid "RTN","ACKQUTL2",184,0) UC(X) ; convert X to uppercase "RTN","ACKQUTL2",185,0) Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") "RTN","ACKQUTL2",186,0) ; "VER") 8.0^22.0 "BLD",7150,6) ^11 **END** **END**