- 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 Jan 18, 2025@03:32:50 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