ACKQAS ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits ; 04/01/99
;;3.0;QUASAR;**1,10,15**;Feb 11, 2000;Build 2
;Call DEM^VADPT supported by DBIA #10061
;
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
IVD ; INITIAL VISIT DATE ** TRIGGERED FROM PATIENT NAME ***
N Y,DDD,DD,DFN,D0,%DT
S DFN=X,X=$S('$D(^ACK(509850.2,DFN,0)):"",'$P(^(0),U,2):"",1:$P(^(0),U,2))
I 'X D
. F D Q:X=""!(X'>DT)
.. S Y=ACKVD D DD^%DT S %DT="AEP",%DT("A")="INITIAL VISIT DATE: "
.. S %DT("B")=Y D ^%DT K %DT S X=$S(Y<1:"",1:Y)
.. I X>DT W !,"No Future Dates Allowed",!
K A1
Q
;
VISIT ; New visit data input
N ACKOUT
I '$O(^ACK(509850.8,0)) W !,"A&SP site parameters must be established before visits can be entered.",! Q
;
D LIST^DIC(509850.83,",1,",".01","I","*","","","","","","ACKTRGT","ACKMSG")
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
;
; Get the Division
DIV ;
I $D(ACKDVN),$D(CLINVARR),$P($G(ACKDVN),U,2)=1,$G(CLINVARR)<2 G VEXIT
D VEXIT
S ACKDVN=$$DIV^ACKQUTL2(1,.ACKDIV) G:$P(ACKDVN,U,1)="0" VEXIT
I '$P(ACKDVN,U,2) W !!!!!,"No Active Divisions Set up on Site Parameters File" W ! H 1 G VEXIT
S ACKDIV=$O(ACKDIV("")),ACKDIV=$P(ACKDIV(ACKDIV),U,1) ; use division IEN of Parameter file
I $P(ACKDVN,U,2)>1 W " Station Number : "_$$GET1^DIQ(40.8,ACKDIV,1)
;
; Get clinic
CLIN S ACKCLIN=$$CLIN^ACKQASU1(ACKDIV,"U") G:ACKCLIN=""&($P($G(ACKDVN),U,2)=1) VEXIT G:ACKCLIN="" DIV
I ACKCLIN=0 W !!!!!,"No Clinics set up for Division " W ! H 1 G DIV
S ACKCLIN=$P(ACKCLIN,U,1) ; Use clinic IEN from Clinic file
; Get Clinic stop code
D STOP
;
W !!!,"Clinic: ",$$GET1^DIQ(44,ACKCLIN,.01)," Stop Code: ",ACKCSC(1)
;
; Get visit date
VDATE S DIR(0)="D^:DT:AEX",DIR("A")="Enter Visit Date",DIR("B")="TODAY"
S DIR("?")="Enter the visit date or press return for TODAY. Future dates not allowed",DIR("??")="^D HELP^%DTC"
D ^DIR K DIR I X?1"^"1.E W !,"Jumping not allowed." G VDATE
G:$D(DIRUT) DIV
S ACKVD=Y
;
;
PATIENT S DIC="^ACK(509850.2,",DIC(0)="AEMQL",DLAYGO=509850.2
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"
S ACKLAYGO="" D ^DIC I X?1"^"1.E W !,"Jumping not allowed." G PATIENT
G:$D(DTOUT) DIV
I X="^" G DIV
I Y<0 W !,"This is a required response. Enter '^' to exit" G PATIENT
S (ACKPAT,DFN)=+Y
S ACKDFN=DFN
;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
S ACKOUT=0
D CHKDTH
I ACKOUT=1 S ACKOUT=0 G PATIENT
;; END ACKQ*3*10
; Check to see if Patient has a Primary Eligibility
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
;
; check for duplicate visits (same date/same patient) allow user to select one
S ACKVSEL=$$DUPCHK^ACKQASU1(ACKPAT,ACKVD) G:ACKVSEL=-1 DIV
S (DA,ACKY)=ACKVSEL ; either 0 (no visit selected) or selected visit ien
;
S (ACKFLG1,ACKFLG2)=0 I DA D I (ACKFLG1)!(ACKFLG2) D VEXIT G VISIT
.; Compare clinic location/stop code of selected visit with
.; original clinic location/stop code.
.S ACKESITE=$P($G(^ACK(509850.6,ACKY,0)),U,6),ACKECSC=$P($G(^ACK(509850.6,ACKY,2)),U)
.I ACKESITE'=ACKCLIN S ACKFLG1=1
.I ACKECSC'=ACKCSC S ACKFLG2=1
.I (ACKFLG1)!(ACKFLG2) K DA D
..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.",!
;
; Get PCE flag - 1 if division set to send to PCE else 0
S ACKPCE=$$PCE^ACKQUTL4(ACKDIV,ACKVD)
;
; Existing A&SP Patient
I DA D EDIT^ACKQAS5 G VISIT
;
; New visit
K DD,DO,DA,D0
S ACKVISIT="NEW",ACKVTME="" ; indicates this is a new visit
;
; If PCE interface not on skip to Call Template logic
I 'ACKPCE S ACKVTME="" G FILE
;
PCE ; Select a PCE visit
;
; Run function to check if there is a PCE visit for today
I '$$PCEVST1^ACKQASU1(ACKVD,ACKPAT,ACKCLIN) G APPMNT
;
; As PCE visits must exist on the visit date run the API that displays
; them and prompts the user to either select one or add a new visit.
S ACKPCENO=$$VISITLST^PXAPI(ACKPAT,ACKVD,ACKVD,ACKCLIN,"APO","","A")
I ACKPCENO="-1" G DIV ; Go back to Division prompt if '^' entered
S ACKVTME=""
; I ACKPCENO="A" 'ADD' selected user wishes to create new visit
I ACKPCENO'="A" G FILE
;
APPMNT ; Check for any appointments for the patient on this date.
S VASD("C",ACKCLIN)="",VASD("T")=ACKVD,VASD("F")=ACKVD
S VASD("W")="129"
K ^UTILITY("VASD",$J) D SDA^VADPT
I '$D(^UTILITY("VASD",$J)) G FILE ; If no appointments goto PCE check
;
; Displays headings and appointments
;
D DISP^ACKQASU
;
; User is prompted to choose or create a new visit.
;
APPMNT1 S ACKNUM=$O(^UTILITY("VASD",$J,""),-1)
S DIR("A")=" Select Appointment (1-"_ACKNUM_") or (N)ew Visit "
S DIR("B")=1
S DIR("?")=" Select number on left of the list or 'N' for New Visit"
S DIR(0)="F^1:2^S:X=""n"" X=""N"" K:X'=""N""&((+X<1)!(+X>ACKNUM)) X"
D ^DIR K DIR,ACKNUM
I X?1"^"1.E W !,"Jumping not allowed." G APPMNT1
G:$D(DIRUT) DIV ; Go back to division if '^' entered.
;
I X'="N"&(X'="n") S X=+X,ACKVTME=$P(^UTILITY("VASD",$J,X,"I"),U,1),ACKVTME=$P(ACKVTME,".",2),ACKAPMNT=1
K ^UTILITY("VASD",$J)
;
FILE ; Set up dummy record and run input template
;
; If Appointment Time is not yet known, but a PCE Visit was selected, get the time
I ACKVTME="",ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D
. S ACKVTME=$$GETPCETM^ACKQASU(ACKPCENO),ACKVTME=$P($P(ACKVTME,U,1),".",2)
. I 'ACKVTME S ACKVTME="" Q
;
I ACKPCE,$G(ACKAPMNT)'=1,'$$ACKAPMNT^ACKQASU7(ACKVD,ACKVTME,ACKCLIN,ACKPAT) D VEXIT,HEADING G VISIT
K ACKAPMNT
;
; Check to see if entry is on 'APCE' cross ref. if so either return to
; Division prompt or null out appointment time variable.
I ACKVTME'="",$D(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)) D I 'ACKQCHK D UNLOCK,VEXIT,HEADING G VISIT
. S ACKQCHK=$$DUPEDATA^ACKQASU(ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)
. I 'ACKQCHK Q
. ; user has decided to continue, so TIME is deleted and PCE VISIT is deleted
. ; this ensures that the visit is treated as brand new when sent to PCE
. S ACKVTME="" ; time
. S ACKPCENO="" ; pce visit ien
;
; create new visit entry
;
S DIC="^ACK(509850.6,",DIC(0)="L",DLAYGO=509850.6,ACKLAYGO=""
S X=ACKVD D FILE^DICN,CHKDT ; File a dummy record prior to template
S ACKVIEN=+$P(Y,U,1) ; Get visit IEN from Y value.
;
K ACKARR
S ACKARR(509850.6,ACKVIEN_",",2.6)=ACKCLIN
S ACKARR(509850.6,ACKVIEN_",",60)=ACKDIV
I +ACKVTME S ACKARR(509850.6,ACKVIEN_",",55)="."_ACKVTME ; file time if known
I +$G(ACKPCENO)'=0 S ACKARR(509850.6,ACKVIEN_",",125)=ACKPCENO ; file PCE number if one selected
D STOP S ACKARR(509850.6,ACKVIEN_",",4)=ACKCSC ; file visit stop (required by COPYPCE)
D FILE^DIE("","ACKARR")
;
; Lock the record
L +^ACK(509850.6,ACKVIEN)
;
; Write away any derived PCE values to visit record
I ACKPCE,$G(ACKPCENO)'="",$G(ACKPCENO)'="A" D I +ACKERR D DEL,UNLOCK,VEXIT,HEADING G VISIT
. S ACKERR=$$COPYPCE^ACKQASU4(ACKVIEN,ACKPCENO)
. ; if error found, display and reset ACKERR according to whether the
. ; user wants to continue (SHOWPCE returns 1=exit,0=continue)
. I +ACKERR S ACKERR=$$SHOWPCE^ACKQASU7($NA(^TMP("ACKQASU4",$J,"COPYPCE","ERROR")))
;
;
TPLATE ; Call template
S DIE="^ACK(509850.6,",(DA,ACKDA)=ACKVIEN,DR="[ACKQAS VISIT ENTRY]" D ^DIE
;
K ACKREQ
I $G(ACKLOSS)'="",$$AUDIO^ACKQUTL4 D UTLAUD^ACKQASU2
S ACKQTST=$$POST^ACKQASU2(ACKVIEN) I 'ACKQTST S ACKDFN=DFN G TPLATE
I ACKPCE,ACKQTST=1 I '$$PCESEND^ACKQASU3(ACKVIEN) S ACKDFN=DFN G TPLATE
D UNLOCK,VEXIT,HEADING G VISIT
;
VEXIT ; Kill off variables at end of processing
;
D KILL^ACKQASU
D KILL^%ZISS
Q
;
AOA ; COMPUTE AGE ON APPOINTMENT DATE
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
Q
;
CHKDT ;
S ACKMON=$E(X,1,5) S ACKGEN=$S($D(^ACK(509850.7,ACKMON,0)):^(0),1:"")
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.",!
Q
;
SITE ;
S DIR(0)="P^ACK(509850.8,1,1,:AEMQ",DA(1)=1
S DIR("A")="Select Clinic Location"
S DIR("?")="Choose the clinic location that should be associated with these visits."
D ^DIR K DIR S:'$D(DIRUT) ACKSITE=+Y Q:$D(DIRUT)
;
STOP ;
S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,8,"I")
S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
S ACKCSC=""
I ACKCSC(1)=203 S ACKCSC="A"
I ACKCSC(1)=204 S ACKCSC="S"
I ACKCSC="" D
. S ACKCSCP=$$GET1^DIQ(44,ACKCLIN,2503,"I")
. S ACKCSC(1)=$S('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
. I ACKCSC(1)=203 S ACKCSC="AT"
. I ACKCSC(1)=204 S ACKCSC="ST"
;
K ACKCSCP
Q
;
;
UNLOCK ; Unlock Locked record
L
Q
;
HEADING ;
W @IOF
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.",!
Q
;
DEL W !!,$C(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
S DIK="^ACK(509850.6,",DA=ACKVIEN D ^DIK
Q
;
CHKDTH ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
N I,X,Y,ACKDIRUT,ACK,VA,VADM,VAERR
D DEM^VADPT
S ACK(4)=""
I VADM(6)'="" D
.S Y=$P(VADM(6),"^",2)
.X ^DD("DD")
.S ACK(4)="[PATIENT DIED ON "_$P(Y,"@")_"]"
I ACK(4)'="" W !!,ACK(4),! S ACKOUT=1
;; END ACKQ*3*10
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQAS 9870 printed Dec 13, 2024@02:31:40 Page 2
ACKQAS ;AUG/JLTP BIR/PTD HCIOFO/BH-New Clinic Visits ; 04/01/99
+1 ;;3.0;QUASAR;**1,10,15**;Feb 11, 2000;Build 2
+2 ;Call DEM^VADPT supported by DBIA #10061
+3 ;
+4 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+5 ;
IVD ; INITIAL VISIT DATE ** TRIGGERED FROM PATIENT NAME ***
+1 NEW Y,DDD,DD,DFN,D0,%DT
+2 SET DFN=X
SET X=$SELECT('$DATA(^ACK(509850.2,DFN,0)):"",'$PIECE(^(0),U,2):"",1:$PIECE(^(0),U,2))
+3 IF 'X
Begin DoDot:1
+4 FOR
Begin DoDot:2
+5 SET Y=ACKVD
DO DD^%DT
SET %DT="AEP"
SET %DT("A")="INITIAL VISIT DATE: "
+6 SET %DT("B")=Y
DO ^%DT
KILL %DT
SET X=$SELECT(Y<1:"",1:Y)
+7 IF X>DT
WRITE !,"No Future Dates Allowed",!
End DoDot:2
if X=""!(X'>DT)
QUIT
End DoDot:1
+8 KILL A1
+9 QUIT
+10 ;
VISIT ; New visit data input
+1 NEW ACKOUT
+2 IF '$ORDER(^ACK(509850.8,0))
WRITE !,"A&SP site parameters must be established before visits can be entered.",!
QUIT
+3 ;
+4 DO LIST^DIC(509850.83,",1,",".01","I","*","","","","","","ACKTRGT","ACKMSG")
+5 IF '$PIECE($GET(ACKTRGT("DILIST",0)),U,1)
WRITE !,"No Divisions have been set up select the Site Parameters function to set up",!,"Division entries.",!
QUIT
+6 ;
+7 ; Get the Division
DIV ;
+1 IF $DATA(ACKDVN)
IF $DATA(CLINVARR)
IF $PIECE($GET(ACKDVN),U,2)=1
IF $GET(CLINVARR)<2
GOTO VEXIT
+2 DO VEXIT
+3 SET ACKDVN=$$DIV^ACKQUTL2(1,.ACKDIV)
if $PIECE(ACKDVN,U,1)="0"
GOTO VEXIT
+4 IF '$PIECE(ACKDVN,U,2)
WRITE !!!!!,"No Active Divisions Set up on Site Parameters File"
WRITE !
HANG 1
GOTO VEXIT
+5 ; use division IEN of Parameter file
SET ACKDIV=$ORDER(ACKDIV(""))
SET ACKDIV=$PIECE(ACKDIV(ACKDIV),U,1)
+6 IF $PIECE(ACKDVN,U,2)>1
WRITE " Station Number : "_$$GET1^DIQ(40.8,ACKDIV,1)
+7 ;
+8 ; Get clinic
CLIN SET ACKCLIN=$$CLIN^ACKQASU1(ACKDIV,"U")
if ACKCLIN=""&($PIECE($GET(ACKDVN),U,2)=1)
GOTO VEXIT
if ACKCLIN=""
GOTO DIV
+1 IF ACKCLIN=0
WRITE !!!!!,"No Clinics set up for Division "
WRITE !
HANG 1
GOTO DIV
+2 ; Use clinic IEN from Clinic file
SET ACKCLIN=$PIECE(ACKCLIN,U,1)
+3 ; Get Clinic stop code
+4 DO STOP
+5 ;
+6 WRITE !!!,"Clinic: ",$$GET1^DIQ(44,ACKCLIN,.01)," Stop Code: ",ACKCSC(1)
+7 ;
+8 ; Get visit date
VDATE SET DIR(0)="D^:DT:AEX"
SET DIR("A")="Enter Visit Date"
SET DIR("B")="TODAY"
+1 SET DIR("?")="Enter the visit date or press return for TODAY. Future dates not allowed"
SET DIR("??")="^D HELP^%DTC"
+2 DO ^DIR
KILL DIR
IF X?1"^"1.E
WRITE !,"Jumping not allowed."
GOTO VDATE
+3 if $DATA(DIRUT)
GOTO DIV
+4 SET ACKVD=Y
+5 ;
+6 ;
PATIENT SET DIC="^ACK(509850.2,"
SET DIC(0)="AEMQL"
SET DLAYGO=509850.2
+1 SET 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"
+2 SET ACKLAYGO=""
DO ^DIC
IF X?1"^"1.E
WRITE !,"Jumping not allowed."
GOTO PATIENT
+3 if $DATA(DTOUT)
GOTO DIV
+4 IF X="^"
GOTO DIV
+5 IF Y<0
WRITE !,"This is a required response. Enter '^' to exit"
GOTO PATIENT
+6 SET (ACKPAT,DFN)=+Y
+7 SET ACKDFN=DFN
+8 ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
+9 SET ACKOUT=0
+10 DO CHKDTH
+11 IF ACKOUT=1
SET ACKOUT=0
GOTO PATIENT
+12 ;; END ACKQ*3*10
+13 ; Check to see if Patient has a Primary Eligibility
+14 IF '$$ELIGCHK^ACKQASU
WRITE !!,"DATA ERROR : Patient has no Primary Eligibility defined on the Patient File.",!,"This requires updating before QUASAR processing can commence.",!
DO VEXIT
GOTO DIV
+15 ;
+16 ; check for duplicate visits (same date/same patient) allow user to select one
+17 SET ACKVSEL=$$DUPCHK^ACKQASU1(ACKPAT,ACKVD)
if ACKVSEL=-1
GOTO DIV
+18 ; either 0 (no visit selected) or selected visit ien
SET (DA,ACKY)=ACKVSEL
+19 ;
+20 SET (ACKFLG1,ACKFLG2)=0
IF DA
Begin DoDot:1
+21 ; Compare clinic location/stop code of selected visit with
+22 ; original clinic location/stop code.
+23 SET ACKESITE=$PIECE($GET(^ACK(509850.6,ACKY,0)),U,6)
SET ACKECSC=$PIECE($GET(^ACK(509850.6,ACKY,2)),U)
+24 IF ACKESITE'=ACKCLIN
SET ACKFLG1=1
+25 IF ACKECSC'=ACKCSC
SET ACKFLG2=1
+26 IF (ACKFLG1)!(ACKFLG2)
KILL DA
Begin DoDot:2
+27 WRITE !!,"The "_$SELECT(ACKFLG1:"clinic location",1:"clinic stop code")_" for the selected appointment does not match",!,"the current "_$SELECT(ACKFLG1:"clinic location",1:"clinic stop code")_". Transaction not allowed.",!
End DoDot:2
End DoDot:1
IF (ACKFLG1)!(ACKFLG2)
DO VEXIT
GOTO VISIT
+28 ;
+29 ; Get PCE flag - 1 if division set to send to PCE else 0
+30 SET ACKPCE=$$PCE^ACKQUTL4(ACKDIV,ACKVD)
+31 ;
+32 ; Existing A&SP Patient
+33 IF DA
DO EDIT^ACKQAS5
GOTO VISIT
+34 ;
+35 ; New visit
+36 KILL DD,DO,DA,D0
+37 ; indicates this is a new visit
SET ACKVISIT="NEW"
SET ACKVTME=""
+38 ;
+39 ; If PCE interface not on skip to Call Template logic
+40 IF 'ACKPCE
SET ACKVTME=""
GOTO FILE
+41 ;
PCE ; Select a PCE visit
+1 ;
+2 ; Run function to check if there is a PCE visit for today
+3 IF '$$PCEVST1^ACKQASU1(ACKVD,ACKPAT,ACKCLIN)
GOTO APPMNT
+4 ;
+5 ; As PCE visits must exist on the visit date run the API that displays
+6 ; them and prompts the user to either select one or add a new visit.
+7 SET ACKPCENO=$$VISITLST^PXAPI(ACKPAT,ACKVD,ACKVD,ACKCLIN,"APO","","A")
+8 ; Go back to Division prompt if '^' entered
IF ACKPCENO="-1"
GOTO DIV
+9 SET ACKVTME=""
+10 ; I ACKPCENO="A" 'ADD' selected user wishes to create new visit
+11 IF ACKPCENO'="A"
GOTO FILE
+12 ;
APPMNT ; Check for any appointments for the patient on this date.
+1 SET VASD("C",ACKCLIN)=""
SET VASD("T")=ACKVD
SET VASD("F")=ACKVD
+2 SET VASD("W")="129"
+3 KILL ^UTILITY("VASD",$JOB)
DO SDA^VADPT
+4 ; If no appointments goto PCE check
IF '$DATA(^UTILITY("VASD",$JOB))
GOTO FILE
+5 ;
+6 ; Displays headings and appointments
+7 ;
+8 DO DISP^ACKQASU
+9 ;
+10 ; User is prompted to choose or create a new visit.
+11 ;
APPMNT1 SET ACKNUM=$ORDER(^UTILITY("VASD",$JOB,""),-1)
+1 SET DIR("A")=" Select Appointment (1-"_ACKNUM_") or (N)ew Visit "
+2 SET DIR("B")=1
+3 SET DIR("?")=" Select number on left of the list or 'N' for New Visit"
+4 SET DIR(0)="F^1:2^S:X=""n"" X=""N"" K:X'=""N""&((+X<1)!(+X>ACKNUM)) X"
+5 DO ^DIR
KILL DIR,ACKNUM
+6 IF X?1"^"1.E
WRITE !,"Jumping not allowed."
GOTO APPMNT1
+7 ; Go back to division if '^' entered.
if $DATA(DIRUT)
GOTO DIV
+8 ;
+9 IF X'="N"&(X'="n")
SET X=+X
SET ACKVTME=$PIECE(^UTILITY("VASD",$JOB,X,"I"),U,1)
SET ACKVTME=$PIECE(ACKVTME,".",2)
SET ACKAPMNT=1
+10 KILL ^UTILITY("VASD",$JOB)
+11 ;
FILE ; Set up dummy record and run input template
+1 ;
+2 ; If Appointment Time is not yet known, but a PCE Visit was selected, get the time
+3 IF ACKVTME=""
IF ACKPCE
IF $GET(ACKPCENO)'=""
IF $GET(ACKPCENO)'="A"
Begin DoDot:1
+4 SET ACKVTME=$$GETPCETM^ACKQASU(ACKPCENO)
SET ACKVTME=$PIECE($PIECE(ACKVTME,U,1),".",2)
+5 IF 'ACKVTME
SET ACKVTME=""
QUIT
End DoDot:1
+6 ;
+7 IF ACKPCE
IF $GET(ACKAPMNT)'=1
IF '$$ACKAPMNT^ACKQASU7(ACKVD,ACKVTME,ACKCLIN,ACKPAT)
DO VEXIT
DO HEADING
GOTO VISIT
+8 KILL ACKAPMNT
+9 ;
+10 ; Check to see if entry is on 'APCE' cross ref. if so either return to
+11 ; Division prompt or null out appointment time variable.
+12 IF ACKVTME'=""
IF $DATA(^ACK(509850.6,"APCE",ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME))
Begin DoDot:1
+13 SET ACKQCHK=$$DUPEDATA^ACKQASU(ACKPAT,ACKCLIN,ACKVD,"."_ACKVTME)
+14 IF 'ACKQCHK
QUIT
+15 ; user has decided to continue, so TIME is deleted and PCE VISIT is deleted
+16 ; this ensures that the visit is treated as brand new when sent to PCE
+17 ; time
SET ACKVTME=""
+18 ; pce visit ien
SET ACKPCENO=""
End DoDot:1
IF 'ACKQCHK
DO UNLOCK
DO VEXIT
DO HEADING
GOTO VISIT
+19 ;
+20 ; create new visit entry
+21 ;
+22 SET DIC="^ACK(509850.6,"
SET DIC(0)="L"
SET DLAYGO=509850.6
SET ACKLAYGO=""
+23 ; File a dummy record prior to template
SET X=ACKVD
DO FILE^DICN
DO CHKDT
+24 ; Get visit IEN from Y value.
SET ACKVIEN=+$PIECE(Y,U,1)
+25 ;
+26 KILL ACKARR
+27 SET ACKARR(509850.6,ACKVIEN_",",2.6)=ACKCLIN
+28 SET ACKARR(509850.6,ACKVIEN_",",60)=ACKDIV
+29 ; file time if known
IF +ACKVTME
SET ACKARR(509850.6,ACKVIEN_",",55)="."_ACKVTME
+30 ; file PCE number if one selected
IF +$GET(ACKPCENO)'=0
SET ACKARR(509850.6,ACKVIEN_",",125)=ACKPCENO
+31 ; file visit stop (required by COPYPCE)
DO STOP
SET ACKARR(509850.6,ACKVIEN_",",4)=ACKCSC
+32 DO FILE^DIE("","ACKARR")
+33 ;
+34 ; Lock the record
+35 LOCK +^ACK(509850.6,ACKVIEN)
+36 ;
+37 ; Write away any derived PCE values to visit record
+38 IF ACKPCE
IF $GET(ACKPCENO)'=""
IF $GET(ACKPCENO)'="A"
Begin DoDot:1
+39 SET ACKERR=$$COPYPCE^ACKQASU4(ACKVIEN,ACKPCENO)
+40 ; if error found, display and reset ACKERR according to whether the
+41 ; user wants to continue (SHOWPCE returns 1=exit,0=continue)
+42 IF +ACKERR
SET ACKERR=$$SHOWPCE^ACKQASU7($NAME(^TMP("ACKQASU4",$JOB,"COPYPCE","ERROR")))
End DoDot:1
IF +ACKERR
DO DEL
DO UNLOCK
DO VEXIT
DO HEADING
GOTO VISIT
+43 ;
+44 ;
TPLATE ; Call template
+1 SET DIE="^ACK(509850.6,"
SET (DA,ACKDA)=ACKVIEN
SET DR="[ACKQAS VISIT ENTRY]"
DO ^DIE
+2 ;
+3 KILL ACKREQ
+4 IF $GET(ACKLOSS)'=""
IF $$AUDIO^ACKQUTL4
DO UTLAUD^ACKQASU2
+5 SET ACKQTST=$$POST^ACKQASU2(ACKVIEN)
IF 'ACKQTST
SET ACKDFN=DFN
GOTO TPLATE
+6 IF ACKPCE
IF ACKQTST=1
IF '$$PCESEND^ACKQASU3(ACKVIEN)
SET ACKDFN=DFN
GOTO TPLATE
+7 DO UNLOCK
DO VEXIT
DO HEADING
GOTO VISIT
+8 ;
VEXIT ; Kill off variables at end of processing
+1 ;
+2 DO KILL^ACKQASU
+3 DO KILL^%ZISS
+4 QUIT
+5 ;
AOA ; COMPUTE AGE ON APPOINTMENT DATE
+1 NEW DFN,VA,VADM,VAERR,X1,X2
SET DFN=$PIECE(^ACK(509850.6,D0,0),U,2)
SET X1=$PIECE(^(0),U)
DO DEM^VADPT
SET X2=+VADM(3)
SET X=X1-X2\10000
+2 QUIT
+3 ;
CHKDT ;
+1 SET ACKMON=$EXTRACT(X,1,5)
SET ACKGEN=$SELECT($DATA(^ACK(509850.7,ACKMON,0)):^(0),1:"")
+2 if '$LENGTH(ACKGEN)
QUIT
IF $PIECE(ACKGEN,U,4)
WRITE !!,$CHAR(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.",!
+3 QUIT
+4 ;
SITE ;
+1 SET DIR(0)="P^ACK(509850.8,1,1,:AEMQ"
SET DA(1)=1
+2 SET DIR("A")="Select Clinic Location"
+3 SET DIR("?")="Choose the clinic location that should be associated with these visits."
+4 DO ^DIR
KILL DIR
if '$DATA(DIRUT)
SET ACKSITE=+Y
if $DATA(DIRUT)
QUIT
+5 ;
STOP ;
+1 SET ACKCSCP=$$GET1^DIQ(44,ACKCLIN,8,"I")
+2 SET ACKCSC(1)=$SELECT('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
+3 SET ACKCSC=""
+4 IF ACKCSC(1)=203
SET ACKCSC="A"
+5 IF ACKCSC(1)=204
SET ACKCSC="S"
+6 IF ACKCSC=""
Begin DoDot:1
+7 SET ACKCSCP=$$GET1^DIQ(44,ACKCLIN,2503,"I")
+8 SET ACKCSC(1)=$SELECT('ACKCSCP:0,1:$$GET1^DIQ(40.7,ACKCSCP,1))
+9 IF ACKCSC(1)=203
SET ACKCSC="AT"
+10 IF ACKCSC(1)=204
SET ACKCSC="ST"
End DoDot:1
+11 ;
+12 KILL ACKCSCP
+13 QUIT
+14 ;
+15 ;
UNLOCK ; Unlock Locked record
+1 LOCK
+2 QUIT
+3 ;
HEADING ;
+1 WRITE @IOF
+2 WRITE !,"This option is used to enter new A&SP clinic visits. Existing clinic",!,"visits should be updated with the Edit an Existing Visit option.",!
+3 QUIT
+4 ;
DEL WRITE !!,$CHAR(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
+1 SET DIK="^ACK(509850.6,"
SET DA=ACKVIEN
DO ^DIK
+2 QUIT
+3 ;
CHKDTH ;; ACKQ*3*10 ADD CHECK FOR DECEASED PATIENT
+1 NEW I,X,Y,ACKDIRUT,ACK,VA,VADM,VAERR
+2 DO DEM^VADPT
+3 SET ACK(4)=""
+4 IF VADM(6)'=""
Begin DoDot:1
+5 SET Y=$PIECE(VADM(6),"^",2)
+6 XECUTE ^DD("DD")
+7 SET ACK(4)="[PATIENT DIED ON "_$PIECE(Y,"@")_"]"
End DoDot:1
+8 IF ACK(4)'=""
WRITE !!,ACK(4),!
SET ACKOUT=1
+9 ;; END ACKQ*3*10
+10 QUIT
