ACKQASU ;HCIOFO/BH - New/Edit Visit Utilities ;04/01/99
;;3.0;QUASAR;**8,15,16,22,21**;Feb 11, 2000;Build 40
;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
;
; Reference/ICR
; $$CODEC^ICDEX - 5747
;
;
ELIGCHK() ; Checks to see if there is a Primary Eligibility (which there
; always should be) if there's not (i.e. data error) pass back zero.
;
N ACKFLG
D ELIG^VADPT S:VAEL(1)="" ACKFLG="0" S:VAEL(1)'="" ACKFLG=1
K VAEL
Q ACKFLG
;
DISP ; Displays headings and Patient Appointments
;
; CLEAR SCREEN WRITE FROM TOP
D ENS^%ZISS
W @IOF
; Get date for display
D NOW^%DTC S Y=% D DD^%DT S ACKDDT1=$TR(Y,"@"," "),ACKDDT2=X
S ACKSSN=$$GET1^DIQ(2,ACKPAT,".09")
W " - ",IOUON,"APPOINTMENT LIST",IOUOFF," -",!
W !," Name : "_$$GET1^DIQ(2,ACKPAT,".01")
W ?38,"SSN : ",$E(ACKSSN,1,3)_"-"_$E(ACKSSN,4,5)_"-"_$E(ACKSSN,6,9)
W !," Date : "_$E(ACKDDT2,4,5)_"/"_$E(ACKDDT2,6,7)_"/"_$E(ACKDDT2,2,3)
W ?38,"Clinic : "_$$GET1^DIQ(44,ACKCLIN,.01)
W !,IOUON," ",IOUOFF
;
;
W !!," ",IOUON,"Appt Date/Time",IOUOFF," ",IOUON,"Status",IOUOFF," ",IOUON,"Appointment Type",IOUOFF
K ACKDDT1,ACKDDT2,ACKSSN
;
S ACKK3=""
F S ACKK3=$O(^UTILITY("VASD",$J,ACKK3)) Q:ACKK3="" D
. S ACKSTRIN=^UTILITY("VASD",$J,ACKK3,"E")
. W !!," "_ACKK3_"."
. W ?4,$P($P(ACKSTRIN,U,1),"@",1)_" "_$P($P(ACKSTRIN,U,1),"@",2)
. W ?23,$S($P(ACKSTRIN,U,3)'="":$P(ACKSTRIN,U,3),1:"NO ACTION TAKEN")
. W ?49,$P(ACKSTRIN,U,4)
W !!!
Q
;
KILL ; Kill off values at end of processing
K ACK0,ACK2,ACKCAT,ACKCD,ACKCDN,ACKCLN,ACKCNT,ACKCP,ACKDA,ACKDC,ACKDUP
K ACKDUPN,ACKECSC,ACKESITE,ACKFLD,ACKFLG1,ACKFLG2,ACKGEN,ACKI,ACKLAYGO
K ACKMOD,ACKMON,ACKQCPS,ACKQCPT,ACKQRAW,ACKRAW,ACKREQ,ACKSEL,ACKSTF
K ACKSIG,ACKTM,ACKVD,ACKY,ACKDEF,ACKDIVN,ACKCSC,ACKCPNO,ACKCLNO,ACKCLIN
K ACKL1,ACKL2,ACKL3,ACKL4,ACKR1,ACKR2,ACKR3,ACKR4,ACKTITL,%,%DT,%I,%X
K %Y,C,D0,DA,DFN,DIC,DIE,DIK,DIRUT,DLAYGO,DR,DTOUT,DUOUT,I,J,VA,VADM
K VAERR,X,X1,X4,Y,ACKELIG,ACKIEN,ACKK2,ACKLAMD,ACKLOSS,ACKN,ACKPCE
K ACKVISIT,ACKPAT,ACKVIEN,ACKDIV,ACLCLIN,ACKCHK,ACKVIEN,ACKAO,ACKSC
K CLINVAR,DIVARR,ACKRAD,ACKENV,ACKPROV,ACKDIAGD,ACKCPTDS,ACKDIRUT
K ACKPCENO,VSAD,DIVARR,DIV,CLINVARR,ACKTME,ACKSCR,ACKELGCT,ACKELG1
K ACKTRGT,ACKDVN,ACKACKBA,ACKAUDIO,ACKATS,ACKQUIT,ACKMSG,ACKQTST
K ACKQSER,ACKQORG,ACKQIR,ACKQECON,ACKAPMNT,ICPTVDT,ICDVDT,ACKHNC,ACKCV
Q
;
;
DC ; CHECK OUT DIAGNOSTIC CONDITION - ENTER IF NEEDED
N ACKY
Q:$D(^ACK(509850.2,DFN,1,"B",ACKDC))
;ACKQ*3.0*22 updated api
S ACKY=Y D DEM^VADPT S Y=ACKY,X=$$CODEC^ICDEX(80,ACKDC),ACKLN=$P(VADM(1),","),ACKSX=$P(VADM(5),U)
I $G(ACKBGRD)'="1" D
. W !!,X," ",$$DIAGTXT^ACKQUTL8(ACKDC,ACKVD)
. W !,"We have no previous record of diagnostic condition ",X," for ",$S(ACKSX="F":"Ms.",1:"Mr.")," ",ACKLN,"." D ADCODE
. W !,"Ok, I've added this code to ",$S(ACKSX="F":"her",1:"his")," permanent record !",!
I $G(ACKBGRD)=1 D ADCODE
K ACK0,ACKLN,ACKSX,VA,VADM,VAERR,X Q
;
ADCODE ; Adds ICD to permanent record.
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
F L +^ACK(509850.2,DFN,1,0):$G(DILOCKTM,3) Q:$T W:$G(ACKBGRD)'="1" !,"Another user is editing this record."
S (DIC,DIE)="^ACK(509850.2,"_DFN_",1,",DIC(0)="L",DLAYGO=509850.2,ACKLAYGO=""
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
L -^ACK(509850.2,DFN,1,0) Q
;
Q
;
GETPCETM(ACKPCENO) ; get appointment time from a PCE Visit ien
; inputs:- ACKPCENO - PCE Visit ien (from ^AUPNVSIT)
; returned :- 0^ - error (visit not found)
; '.nnnnnn^' - time portion of PCE visit date/time
N ACKDATE,ACKTM
K ^TMP("PXKENC",$J)
D ENCEVENT^PXAPI(ACKPCENO)
S ACKDATE=$P($G(^TMP("PXKENC",$J,ACKPCENO,"VST",ACKPCENO,0)),U,1)
S ACKTM=$S(ACKDATE="":0,1:ACKDATE#1)
K ^TMP("PXKENC",$J)
Q ACKTM_U
;
DUPEDATA(ACKPAT,ACKCLIN,ACKVD,ACKTM) ; If an appointment or PCE visit has been selected for a visit
; which is at the same time, for the same patient, on the same day
; within the same clinic this processing is run.
; inputs:- ACKPAT - patient ien
; ACKCLIN - clinic ien
; ACKVD - visit date (internal)
; ACKTM - appointment time (.NNN - internal)
W !!?4,"ERROR - A visit already exists in QUASAR with the following details..",!
W !?7,"Visit Date: ",$$DATE(ACKVD)," Appointment Time: ",$$TIME(ACKTM)
W !?7," Clinic: ",$$GET1^DIQ(44,ACKCLIN_",",.01,"E")
W !?7," Patient: ",$$GET1^DIQ(509850.2,ACKPAT_",",.01,"E")
W !!?4,"If you choose to continue you must enter a different Appointment Time."
;
; W !!,"There is already an entry within Quasar for this Patient, within the same"
; W !,"Clinic, on the same date at the same time."
; W !!,"Enter '^' to terminate and quit back to the Division prompt"
; W !,"or <RETURN> to continue."
W !
K DIR S DIR(0)="E" D ^DIR K DIR ; Return to Continue '^' to Exit
I X="^" Q 0
Q 1
;
DATE(ACKDATE) ; convert ACKDATE to external format
S Y=ACKDATE D DD^%DT
Q Y
TIME(ACKTIME) ; convert Time to external format
Q $$FMT^ACKQUTL6(ACKTIME,1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQASU 5371 printed Sep 23, 2025@20:08:07 Page 2
ACKQASU ;HCIOFO/BH - New/Edit Visit Utilities ;04/01/99
+1 ;;3.0;QUASAR;**8,15,16,22,21**;Feb 11, 2000;Build 40
+2 ;Per VHA Directive 2004-038, this routine SHOULD NOT be modified.
+3 ;
+4 ; Reference/ICR
+5 ; $$CODEC^ICDEX - 5747
+6 ;
+7 ;
ELIGCHK() ; Checks to see if there is a Primary Eligibility (which there
+1 ; always should be) if there's not (i.e. data error) pass back zero.
+2 ;
+3 NEW ACKFLG
+4 DO ELIG^VADPT
if VAEL(1)=""
SET ACKFLG="0"
if VAEL(1)'=""
SET ACKFLG=1
+5 KILL VAEL
+6 QUIT ACKFLG
+7 ;
DISP ; Displays headings and Patient Appointments
+1 ;
+2 ; CLEAR SCREEN WRITE FROM TOP
+3 DO ENS^%ZISS
+4 WRITE @IOF
+5 ; Get date for display
+6 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET ACKDDT1=$TRANSLATE(Y,"@"," ")
SET ACKDDT2=X
+7 SET ACKSSN=$$GET1^DIQ(2,ACKPAT,".09")
+8 WRITE " - ",IOUON,"APPOINTMENT LIST",IOUOFF," -",!
+9 WRITE !," Name : "_$$GET1^DIQ(2,ACKPAT,".01")
+10 WRITE ?38,"SSN : ",$EXTRACT(ACKSSN,1,3)_"-"_$EXTRACT(ACKSSN,4,5)_"-"_$EXTRACT(ACKSSN,6,9)
+11 WRITE !," Date : "_$EXTRACT(ACKDDT2,4,5)_"/"_$EXTRACT(ACKDDT2,6,7)_"/"_$EXTRACT(ACKDDT2,2,3)
+12 WRITE ?38,"Clinic : "_$$GET1^DIQ(44,ACKCLIN,.01)
+13 WRITE !,IOUON," ",IOUOFF
+14 ;
+15 ;
+16 WRITE !!," ",IOUON,"Appt Date/Time",IOUOFF," ",IOUON,"Status",IOUOFF," ",IOUON,"Appointment Type",IOUOFF
+17 KILL ACKDDT1,ACKDDT2,ACKSSN
+18 ;
+19 SET ACKK3=""
+20 FOR
SET ACKK3=$ORDER(^UTILITY("VASD",$JOB,ACKK3))
if ACKK3=""
QUIT
Begin DoDot:1
+21 SET ACKSTRIN=^UTILITY("VASD",$JOB,ACKK3,"E")
+22 WRITE !!," "_ACKK3_"."
+23 WRITE ?4,$PIECE($PIECE(ACKSTRIN,U,1),"@",1)_" "_$PIECE($PIECE(ACKSTRIN,U,1),"@",2)
+24 WRITE ?23,$SELECT($PIECE(ACKSTRIN,U,3)'="":$PIECE(ACKSTRIN,U,3),1:"NO ACTION TAKEN")
+25 WRITE ?49,$PIECE(ACKSTRIN,U,4)
End DoDot:1
+26 WRITE !!!
+27 QUIT
+28 ;
KILL ; Kill off values at end of processing
+1 KILL ACK0,ACK2,ACKCAT,ACKCD,ACKCDN,ACKCLN,ACKCNT,ACKCP,ACKDA,ACKDC,ACKDUP
+2 KILL ACKDUPN,ACKECSC,ACKESITE,ACKFLD,ACKFLG1,ACKFLG2,ACKGEN,ACKI,ACKLAYGO
+3 KILL ACKMOD,ACKMON,ACKQCPS,ACKQCPT,ACKQRAW,ACKRAW,ACKREQ,ACKSEL,ACKSTF
+4 KILL ACKSIG,ACKTM,ACKVD,ACKY,ACKDEF,ACKDIVN,ACKCSC,ACKCPNO,ACKCLNO,ACKCLIN
+5 KILL ACKL1,ACKL2,ACKL3,ACKL4,ACKR1,ACKR2,ACKR3,ACKR4,ACKTITL,%,%DT,%I,%X
+6 KILL %Y,C,D0,DA,DFN,DIC,DIE,DIK,DIRUT,DLAYGO,DR,DTOUT,DUOUT,I,J,VA,VADM
+7 KILL VAERR,X,X1,X4,Y,ACKELIG,ACKIEN,ACKK2,ACKLAMD,ACKLOSS,ACKN,ACKPCE
+8 KILL ACKVISIT,ACKPAT,ACKVIEN,ACKDIV,ACLCLIN,ACKCHK,ACKVIEN,ACKAO,ACKSC
+9 KILL CLINVAR,DIVARR,ACKRAD,ACKENV,ACKPROV,ACKDIAGD,ACKCPTDS,ACKDIRUT
+10 KILL ACKPCENO,VSAD,DIVARR,DIV,CLINVARR,ACKTME,ACKSCR,ACKELGCT,ACKELG1
+11 KILL ACKTRGT,ACKDVN,ACKACKBA,ACKAUDIO,ACKATS,ACKQUIT,ACKMSG,ACKQTST
+12 KILL ACKQSER,ACKQORG,ACKQIR,ACKQECON,ACKAPMNT,ICPTVDT,ICDVDT,ACKHNC,ACKCV
+13 QUIT
+14 ;
+15 ;
DC ; CHECK OUT DIAGNOSTIC CONDITION - ENTER IF NEEDED
+1 NEW ACKY
+2 if $DATA(^ACK(509850.2,DFN,1,"B",ACKDC))
QUIT
+3 ;ACKQ*3.0*22 updated api
+4 SET ACKY=Y
DO DEM^VADPT
SET Y=ACKY
SET X=$$CODEC^ICDEX(80,ACKDC)
SET ACKLN=$PIECE(VADM(1),",")
SET ACKSX=$PIECE(VADM(5),U)
+5 IF $GET(ACKBGRD)'="1"
Begin DoDot:1
+6 WRITE !!,X," ",$$DIAGTXT^ACKQUTL8(ACKDC,ACKVD)
+7 WRITE !,"We have no previous record of diagnostic condition ",X," for ",$SELECT(ACKSX="F":"Ms.",1:"Mr.")," ",ACKLN,"."
DO ADCODE
+8 WRITE !,"Ok, I've added this code to ",$SELECT(ACKSX="F":"her",1:"his")," permanent record !",!
End DoDot:1
+9 IF $GET(ACKBGRD)=1
DO ADCODE
+10 KILL ACK0,ACKLN,ACKSX,VA,VADM,VAERR,X
QUIT
+11 ;
ADCODE ; Adds ICD to permanent record.
+1 ;we're calling this from FM
NEW 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
+2 FOR
LOCK +^ACK(509850.2,DFN,1,0):$GET(DILOCKTM,3)
if $TEST
QUIT
if $GET(ACKBGRD)'="1"
WRITE !,"Another user is editing this record."
+3 SET (DIC,DIE)="^ACK(509850.2,"_DFN_",1,"
SET DIC(0)="L"
SET DLAYGO=509850.2
SET ACKLAYGO=""
+4 SET DIC("P")=$PIECE(^DD(509850.2,2,0),"^",2)
SET DA(1)=DFN
SET X=ACKDC
DO FILE^DICN
if Y<0
QUIT
SET DA=+Y
SET DR="2;1///"_ACKVD
DO ^DIE
+5 LOCK -^ACK(509850.2,DFN,1,0)
QUIT
+6 ;
+7 QUIT
+8 ;
GETPCETM(ACKPCENO) ; get appointment time from a PCE Visit ien
+1 ; inputs:- ACKPCENO - PCE Visit ien (from ^AUPNVSIT)
+2 ; returned :- 0^ - error (visit not found)
+3 ; '.nnnnnn^' - time portion of PCE visit date/time
+4 NEW ACKDATE,ACKTM
+5 KILL ^TMP("PXKENC",$JOB)
+6 DO ENCEVENT^PXAPI(ACKPCENO)
+7 SET ACKDATE=$PIECE($GET(^TMP("PXKENC",$JOB,ACKPCENO,"VST",ACKPCENO,0)),U,1)
+8 SET ACKTM=$SELECT(ACKDATE="":0,1:ACKDATE#1)
+9 KILL ^TMP("PXKENC",$JOB)
+10 QUIT ACKTM_U
+11 ;
DUPEDATA(ACKPAT,ACKCLIN,ACKVD,ACKTM) ; If an appointment or PCE visit has been selected for a visit
+1 ; which is at the same time, for the same patient, on the same day
+2 ; within the same clinic this processing is run.
+3 ; inputs:- ACKPAT - patient ien
+4 ; ACKCLIN - clinic ien
+5 ; ACKVD - visit date (internal)
+6 ; ACKTM - appointment time (.NNN - internal)
+7 WRITE !!?4,"ERROR - A visit already exists in QUASAR with the following details..",!
+8 WRITE !?7,"Visit Date: ",$$DATE(ACKVD)," Appointment Time: ",$$TIME(ACKTM)
+9 WRITE !?7," Clinic: ",$$GET1^DIQ(44,ACKCLIN_",",.01,"E")
+10 WRITE !?7," Patient: ",$$GET1^DIQ(509850.2,ACKPAT_",",.01,"E")
+11 WRITE !!?4,"If you choose to continue you must enter a different Appointment Time."
+12 ;
+13 ; W !!,"There is already an entry within Quasar for this Patient, within the same"
+14 ; W !,"Clinic, on the same date at the same time."
+15 ; W !!,"Enter '^' to terminate and quit back to the Division prompt"
+16 ; W !,"or <RETURN> to continue."
+17 WRITE !
+18 ; Return to Continue '^' to Exit
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
+19 IF X="^"
QUIT 0
+20 QUIT 1
+21 ;
DATE(ACKDATE) ; convert ACKDATE to external format
+1 SET Y=ACKDATE
DO DD^%DT
+2 QUIT Y
TIME(ACKTIME) ; convert Time to external format
+1 QUIT $$FMT^ACKQUTL6(ACKTIME,1)
