ACKQNQ ;AUG/JLTP,AEM BIR/PTD HCIOFO/BH HCIOFO/AG - Inquire - A&SP Patient ;18 Jun 2013 10:09 AM
;;3.0;QUASAR;**8,14,18,22,21**;Feb 11, 2000;Build 40
;
; Reference/IA
; $$CSI^ICDEX - 5747
;
OPTN ; Introduce option.
S ACKQUIT=0
W:$E(IOST,1,2)="C-" @IOF,!,"This option displays demographic data, inpatient status, and diagnostic",!,"history for a selected A&SP patient."
;
DIC ; LOOKUP PATIENT
N DIC
W ! S DIC=509850.2,DIC(0)="AEMQ" D ^DIC
I (Y<0)!($D(DUOUT)) S ACKQUIT=1 G EXIT
S ACKDFN=+Y
;
ASK ; Update patient's diagnostic history?
S DIR(0)="Y",DIR("A")="Do you want to update this patient's diagnostic history NOW",DIR("B")="NO",DIR("?")="Enter YES to recompile the Problem List; enter NO to continue."
S DIR("??")="^D UPDATE^ACKQHLP1" W ! D ^DIR K DIR G:$D(DIRUT) EXIT I Y=1 D UPDATE
;
DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
I $D(IO("Q")) K IO("Q") S ZTRTN="EN^ACKQNQ",ZTSAVE("ACKDFN")="",ZTDESC="QUASAR - Inquire - A&SP Patient" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT
;
EN U IO N DFN,I,X,Y S DFN=ACKDFN
D DEM^VADPT,INP^VADPT,ELIG^VADPT
S ACKIVD=$$NUMDT^ACKQUTL($P(^ACK(509850.2,DFN,0),U,2))
K ACK S ACK(1)=VADM(1),ACK(2)=$P(VADM(3),U,2),ACK(3)=$P(VADM(2),U,2),ACK(4)=VADM(7),ACK(6)=$P(VAIN(4),U,2)
S ACKINP=$S($L(ACK(6)):1,1:0),ACK(5)="Patient is "_$S(ACKINP:"",1:"not ")_"currently an inpatient."
S ACK(7)=VAIN(5),ACK(8)=$P(VAIN(3),U,2),ACK(9)=$P(VAEL(1),U,2)
;
;
PRINT W:$E(IOST,1,2)="C-" @IOF
D CNTR^ACKQUTL("Patient Inquiry")
;
W !!
W "PATIENT: ",ACK(1),?45,"DOB: ",ACK(2),?63,"SSN: ",ACK(3)
W !,"ELIGIBILITY: ",ACK(9)
W ?45,"INITIAL VISIT DATE: ",ACKIVD
W:$L(ACK(4)) !,ACK(4) W !,ACK(5) D:ACKINP INP
;
I $P(VAEL(3),U,1) W !!,"Patient is Service Connected."
I '$P(VAEL(3),U,1) D
. S ACKPAT=DFN D STATUS^ACKQUTL4 K VASV
. D NOT^ACKQUTL7("Patient is not Service Connected.",ACKAO,ACKRAD,ACKENV)
. K ACKPAT,ACKAO,ACKRAD,ACKENV
;
D RATDIS G:$G(DIRUT) EXIT
D ICDSORT,DIAGHIST
;
EXIT I $G(ACKVISIT)'="",$G(DIRUT)=1 S ACKDIRUT=1 ; Quit flag for template
K %ZIS,ACK,ACKCDST,ACKDATE,ACKDC,ACKDD,ACKDESC,ACKDFN,ACKDN,ACKDX
K ACKI,ACKICD,ACKICDX,ACKINFO,ACKINP,ACKIVD,ACKLINE,ACKQECON,ACKQIR,ACKQORG
K ACKRD,ACKQSER,CNTR0,CNTR9,DATA,DIRUT,DTOUT,DUOUT,IOUOFF,IOUON,POP
K VA,VADM,VAEL,VAERR,VAIN,X,X1,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE
I $G(ACKQUIT)=1 D KILL^%ZISS Q
I $E(IOST,1,2)="C-" W !!,"Press return to continue." R X:DTIME W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
S ACKQUIT=0 G DIC
Q
;
EN1 ; CALL THIS ENTRY POINT INSTEAD OF EN
D HOME^%ZIS G EN
;
;
INP ; PRINT INPATIENT INFO
W !,"WARD: ",ACK(6),?20,"ROOM/BED: ",ACK(7),?40,"TREATING SPEC: ",$E(ACK(8),1,25)
Q
;
;
RATDIS ; Display Patients RATED DISABILITIES
Q:'$O(^DPT(DFN,.372,0))
N ACKRD,RC,X,X1
D ENS^%ZISS
;---
S RC=$$PAGE(5) Q:RC<0 W:'RC !!
W IOUON,"Rated Disabilities",IOUOFF,!
;---
S ACKRD=0
F S ACKRD=$O(^DPT(DFN,.372,ACKRD)) Q:'ACKRD D Q:RC<0
. S RC=$$PAGE(2) Q:RC<0
. W:RC IOUON,"Rated Disabilities (cont'd)",IOUOFF,!
. S X=^DPT(DFN,.372,ACKRD,0),X1=$P(^DIC(31,+X,0),U)
. W !,X1_" ("_$P(X,U,2)_"%)" I $P(X,U,3) W " (SC)"
Q
;
DIAGHIST ;
Q:$D(ACKICD)<10
N ACKI,ACKICD0,ACKICD9,RC
D ENS^%ZISS
;---
S RC=$$PAGE(7) Q:RC<0 W:'RC !!
W IOUON,"Patient Diagnostic History",IOUOFF
W !,$S($P(VADM(5),U)="F":"Ms. ",1:"Mr. "),$P(VADM(1),",")," has been seen for the following:",!
D DIHEAD
;---
S ACKI=""
S ACKICDX=""
F S ACKI=$O(ACKICD(ACKI)) Q:ACKI="" D Q:RC<0
. S RC=$$PAGE(2) Q:RC<0
. I RC D D DIHEAD
. . W IOUON,"Patient Diagnostic History (cont'd)"," (",ACK(1),")",IOUOFF,!
. S ACKICDX=""
. S ACKICDX=$O(ACKICD(ACKI,ACKICDX))
. S ACKCDST(ACKICDX)=ACKICDX
I $D(ACKCDST(1)),$D(ACKCDST(30)) D
. S ACKI="",CNTR9=0,CNTR0=0
. F S ACKI=$O(ACKICD(ACKI)) Q:ACKI="" D
. . S ACKICD=""
. . F S ACKICD=$O(ACKICD(ACKI,ACKICD)) Q:ACKICD="" D
. . . S ACKDX=$P(ACKICD(ACKI,ACKICD),U)
. . . S ACKDESC=$P(ACKICD(ACKI,ACKICD),U,3)
. . . S ACKDATE=$$NUMDT^ACKQUTL($P(ACKICD(ACKI,ACKICD),U,4))
. . . I ACKICD=1 S CNTR9=CNTR9+1 S ACKICD9(CNTR9)=ACKDX_U_ACKDESC_U_ACKDATE
. . . I ACKICD=30 S CNTR0=CNTR0+1 S ACKICD0(CNTR0)=ACKDX_U_ACKDESC_U_ACKDATE
. D PRTHEAD,EXIT Q
S ACKI="" F S ACKI=$O(ACKICD(ACKI)) Q:ACKI="" D Q:RC<0
. S RC=$$PAGE(2) Q:RC<0
. I RC D D DIHEAD
. . W IOUON,"Patient Diagnostic History (cont'd)"," (",ACK(1),")",IOUOFF,! Q
. S ACKICDX=""
. S ACKICDX=$O(ACKICD(ACKI,ACKICDX)) D
. . W !,$P(ACKICD(ACKI,ACKICDX),U),?15,$P(ACKICD(ACKI,ACKICDX),U,3),?60,$$NUMDT^ACKQUTL($P(ACKICD(ACKI,ACKICDX),U,4))
Q
;
CLASDIS ; Display Patient Servive Classifications
N RC
I '$D(ACKQSER),'$D(ACKQORG),'$D(ACKQIR),'$D(ACKQECON) Q
S RC=$$PAGE(5) Q:RC<0 W:'RC !!
D ENS^%ZISS
W IOUON,"Service Classifications",IOUOFF,!
W:$D(ACKQSER) " SERVICE-CONNECTED " W:$D(ACKQORG) " AGENT-ORANGE " W:$D(ACKQIR) " RADIATION " W:$D(ACKQECON) " ENVIRONMENTAL-CONTAMINANTS"
W !
Q
;
;
DIHEAD W !,"DIAGNOSIS",?60,"DATE ENTERED",!,$$REPEAT^XLFSTR("-",IOM-1)
Q
;
;
ICDSORT ;
S ACKI=0 F S ACKI=$O(^ACK(509850.2,DFN,1,ACKI)) Q:'ACKI D
. S ACKDC=^ACK(509850.2,DFN,1,ACKI,0),ACKDD=$P(ACKDC,U,2)
. S ACKICD=$$CSI^ICDEX(80,+ACKDC) ; returns 1 for ICD9 and 30 for ICD10
. S ACKINFO=$$ICDDATA^ICDXCODE(ACKICD,+ACKDC,ACKDD,"I")
. S ACKTGT=$P(ACKINFO,U,3)
. S ACKDN=$P(ACKINFO,U,2)
. S ACKICD(ACKDN,ACKICD)=ACKDN_U_ACKTGT_U_$$DIAGTXT^ACKQUTL8(+ACKDC,ACKDD)_U_ACKDD
K ACKTGT,ACKMSG
Q
;
UPDATE ; Update patient's diagnostic history in 509850.2.
; ACKDFN is defined upon entry to this module.
D WAIT^DICD W !
D PROBLIST^ACKQUTL3(ACKDFN,1)
Q
;
;***** CHECKS IS NEW PAGE SHOULD BE STARTED
;
; [RESERVE] Number of additional reserved lines (0, by default).
; If the current page does not have so many lines
; available, a new page will be started.
;
; [FORCE] Force the prompt
;
; Return values:
;
; -2 Timeout
; -1 User canceled the output ('^' was entered)
; 0 Ok
; 1 New page
;
PAGE(RESERVE,FORCE) ;
N RC
I ($Y'<($G(IOSL,24)-$G(RESERVE,1)))!$G(FORCE) D S $Y=0
. I $E(IOST,1,2)'="C-" W @IOF Q
. N DA,DIR,DIROUT,DTOUT,DUOUT,I,X,Y
. S DIR(0)="E"
. D ^DIR
. S RC=$S($D(DUOUT):-1,$D(DTOUT):-2,1:1)
. W:RC>0 @IOF
Q +$G(RC)
;
PRTHEAD ;
S CNTR9=0,CNTR0=0
W !,"ICD-9-CM",!
F CNTR9=1:1 S DATA=$G(ACKICD9(CNTR9)) Q:'$D(ACKICD9(CNTR9)) D
. S ACKDX=$P(DATA,U)
. S ACKDESC=$P(DATA,U,2)
. S ACKDATE=$P(DATA,U,3)
. K ACKICDDS,ACKARNUM S ACKICDDS=ACKDESC D BRKDESC^ACKQR3(40)
. ;W !,ACKDX,?15,ACKDESC,?60,ACKDATE
. W !,ACKDX,?15,ACKICDDS(1),?60,ACKDATE
. F ACKARNM2=2:1:ACKARNUM W !?15,ACKICDDS(ACKARNM2)
. K ACKICDDS,ACKARNUM,ACKARNM2
W !!,"ICD-10-CM",!
F CNTR0=1:1 S DATA=$G(ACKICD0(CNTR0)) Q:'$D(ACKICD0(CNTR0)) D
. S ACKDX=$P(DATA,U)
. S ACKDESC=$P(DATA,U,2)
. S ACKDATE=$P(DATA,U,3)
. K ACKICDDS,ACKARNUM S ACKICDDS=ACKDESC D BRKDESC^ACKQR3(40)
. ;W !,ACKDX,?15,ACKDESC,?60,ACKDATE
. W !,ACKDX,?15,ACKICDDS(1),?60,ACKDATE
. F ACKARNM2=2:1:ACKARNUM W !?15,ACKICDDS(ACKARNM2)
. K ACKICDDS,ACKARNUM,ACKARNM2
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQNQ 7359 printed Dec 13, 2024@02:32:19 Page 2
ACKQNQ ;AUG/JLTP,AEM BIR/PTD HCIOFO/BH HCIOFO/AG - Inquire - A&SP Patient ;18 Jun 2013 10:09 AM
+1 ;;3.0;QUASAR;**8,14,18,22,21**;Feb 11, 2000;Build 40
+2 ;
+3 ; Reference/IA
+4 ; $$CSI^ICDEX - 5747
+5 ;
OPTN ; Introduce option.
+1 SET ACKQUIT=0
+2 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF,!,"This option displays demographic data, inpatient status, and diagnostic",!,"history for a selected A&SP patient."
+3 ;
DIC ; LOOKUP PATIENT
+1 NEW DIC
+2 WRITE !
SET DIC=509850.2
SET DIC(0)="AEMQ"
DO ^DIC
+3 IF (Y<0)!($DATA(DUOUT))
SET ACKQUIT=1
GOTO EXIT
+4 SET ACKDFN=+Y
+5 ;
ASK ; Update patient's diagnostic history?
+1 SET DIR(0)="Y"
SET DIR("A")="Do you want to update this patient's diagnostic history NOW"
SET DIR("B")="NO"
SET DIR("?")="Enter YES to recompile the Problem List; enter NO to continue."
+2 SET DIR("??")="^D UPDATE^ACKQHLP1"
WRITE !
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
IF Y=1
DO UPDATE
+3 ;
DEV WRITE !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
+1 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
GOTO EXIT
+2 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="EN^ACKQNQ"
SET ZTSAVE("ACKDFN")=""
SET ZTDESC="QUASAR - Inquire - A&SP Patient"
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
GOTO EXIT
+3 ;
EN USE IO
NEW DFN,I,X,Y
SET DFN=ACKDFN
+1 DO DEM^VADPT
DO INP^VADPT
DO ELIG^VADPT
+2 SET ACKIVD=$$NUMDT^ACKQUTL($PIECE(^ACK(509850.2,DFN,0),U,2))
+3 KILL ACK
SET ACK(1)=VADM(1)
SET ACK(2)=$PIECE(VADM(3),U,2)
SET ACK(3)=$PIECE(VADM(2),U,2)
SET ACK(4)=VADM(7)
SET ACK(6)=$PIECE(VAIN(4),U,2)
+4 SET ACKINP=$SELECT($LENGTH(ACK(6)):1,1:0)
SET ACK(5)="Patient is "_$SELECT(ACKINP:"",1:"not ")_"currently an inpatient."
+5 SET ACK(7)=VAIN(5)
SET ACK(8)=$PIECE(VAIN(3),U,2)
SET ACK(9)=$PIECE(VAEL(1),U,2)
+6 ;
+7 ;
PRINT if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
+1 DO CNTR^ACKQUTL("Patient Inquiry")
+2 ;
+3 WRITE !!
+4 WRITE "PATIENT: ",ACK(1),?45,"DOB: ",ACK(2),?63,"SSN: ",ACK(3)
+5 WRITE !,"ELIGIBILITY: ",ACK(9)
+6 WRITE ?45,"INITIAL VISIT DATE: ",ACKIVD
+7 if $LENGTH(ACK(4))
WRITE !,ACK(4)
WRITE !,ACK(5)
if ACKINP
DO INP
+8 ;
+9 IF $PIECE(VAEL(3),U,1)
WRITE !!,"Patient is Service Connected."
+10 IF '$PIECE(VAEL(3),U,1)
Begin DoDot:1
+11 SET ACKPAT=DFN
DO STATUS^ACKQUTL4
KILL VASV
+12 DO NOT^ACKQUTL7("Patient is not Service Connected.",ACKAO,ACKRAD,ACKENV)
+13 KILL ACKPAT,ACKAO,ACKRAD,ACKENV
End DoDot:1
+14 ;
+15 DO RATDIS
if $GET(DIRUT)
GOTO EXIT
+16 DO ICDSORT
DO DIAGHIST
+17 ;
EXIT ; Quit flag for template
IF $GET(ACKVISIT)'=""
IF $GET(DIRUT)=1
SET ACKDIRUT=1
+1 KILL %ZIS,ACK,ACKCDST,ACKDATE,ACKDC,ACKDD,ACKDESC,ACKDFN,ACKDN,ACKDX
+2 KILL ACKI,ACKICD,ACKICDX,ACKINFO,ACKINP,ACKIVD,ACKLINE,ACKQECON,ACKQIR,ACKQORG
+3 KILL ACKRD,ACKQSER,CNTR0,CNTR9,DATA,DIRUT,DTOUT,DUOUT,IOUOFF,IOUON,POP
+4 KILL VA,VADM,VAEL,VAERR,VAIN,X,X1,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE
+5 IF $GET(ACKQUIT)=1
DO KILL^%ZISS
QUIT
+6 IF $EXTRACT(IOST,1,2)="C-"
WRITE !!,"Press return to continue."
READ X:DTIME
WRITE @IOF
+7 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 SET ACKQUIT=0
GOTO DIC
+9 QUIT
+10 ;
EN1 ; CALL THIS ENTRY POINT INSTEAD OF EN
+1 DO HOME^%ZIS
GOTO EN
+2 ;
+3 ;
INP ; PRINT INPATIENT INFO
+1 WRITE !,"WARD: ",ACK(6),?20,"ROOM/BED: ",ACK(7),?40,"TREATING SPEC: ",$EXTRACT(ACK(8),1,25)
+2 QUIT
+3 ;
+4 ;
RATDIS ; Display Patients RATED DISABILITIES
+1 if '$ORDER(^DPT(DFN,.372,0))
QUIT
+2 NEW ACKRD,RC,X,X1
+3 DO ENS^%ZISS
+4 ;---
+5 SET RC=$$PAGE(5)
if RC<0
QUIT
if 'RC
WRITE !!
+6 WRITE IOUON,"Rated Disabilities",IOUOFF,!
+7 ;---
+8 SET ACKRD=0
+9 FOR
SET ACKRD=$ORDER(^DPT(DFN,.372,ACKRD))
if 'ACKRD
QUIT
Begin DoDot:1
+10 SET RC=$$PAGE(2)
if RC<0
QUIT
+11 if RC
WRITE IOUON,"Rated Disabilities (cont'd)",IOUOFF,!
+12 SET X=^DPT(DFN,.372,ACKRD,0)
SET X1=$PIECE(^DIC(31,+X,0),U)
+13 WRITE !,X1_" ("_$PIECE(X,U,2)_"%)"
IF $PIECE(X,U,3)
WRITE " (SC)"
End DoDot:1
if RC<0
QUIT
+14 QUIT
+15 ;
DIAGHIST ;
+1 if $DATA(ACKICD)<10
QUIT
+2 NEW ACKI,ACKICD0,ACKICD9,RC
+3 DO ENS^%ZISS
+4 ;---
+5 SET RC=$$PAGE(7)
if RC<0
QUIT
if 'RC
WRITE !!
+6 WRITE IOUON,"Patient Diagnostic History",IOUOFF
+7 WRITE !,$SELECT($PIECE(VADM(5),U)="F":"Ms. ",1:"Mr. "),$PIECE(VADM(1),",")," has been seen for the following:",!
+8 DO DIHEAD
+9 ;---
+10 SET ACKI=""
+11 SET ACKICDX=""
+12 FOR
SET ACKI=$ORDER(ACKICD(ACKI))
if ACKI=""
QUIT
Begin DoDot:1
+13 SET RC=$$PAGE(2)
if RC<0
QUIT
+14 IF RC
Begin DoDot:2
+15 WRITE IOUON,"Patient Diagnostic History (cont'd)"," (",ACK(1),")",IOUOFF,!
End DoDot:2
DO DIHEAD
+16 SET ACKICDX=""
+17 SET ACKICDX=$ORDER(ACKICD(ACKI,ACKICDX))
+18 SET ACKCDST(ACKICDX)=ACKICDX
End DoDot:1
if RC<0
QUIT
+19 IF $DATA(ACKCDST(1))
IF $DATA(ACKCDST(30))
Begin DoDot:1
+20 SET ACKI=""
SET CNTR9=0
SET CNTR0=0
+21 FOR
SET ACKI=$ORDER(ACKICD(ACKI))
if ACKI=""
QUIT
Begin DoDot:2
+22 SET ACKICD=""
+23 FOR
SET ACKICD=$ORDER(ACKICD(ACKI,ACKICD))
if ACKICD=""
QUIT
Begin DoDot:3
+24 SET ACKDX=$PIECE(ACKICD(ACKI,ACKICD),U)
+25 SET ACKDESC=$PIECE(ACKICD(ACKI,ACKICD),U,3)
+26 SET ACKDATE=$$NUMDT^ACKQUTL($PIECE(ACKICD(ACKI,ACKICD),U,4))
+27 IF ACKICD=1
SET CNTR9=CNTR9+1
SET ACKICD9(CNTR9)=ACKDX_U_ACKDESC_U_ACKDATE
+28 IF ACKICD=30
SET CNTR0=CNTR0+1
SET ACKICD0(CNTR0)=ACKDX_U_ACKDESC_U_ACKDATE
End DoDot:3
End DoDot:2
+29 DO PRTHEAD
DO EXIT
QUIT
End DoDot:1
+30 SET ACKI=""
FOR
SET ACKI=$ORDER(ACKICD(ACKI))
if ACKI=""
QUIT
Begin DoDot:1
+31 SET RC=$$PAGE(2)
if RC<0
QUIT
+32 IF RC
Begin DoDot:2
+33 WRITE IOUON,"Patient Diagnostic History (cont'd)"," (",ACK(1),")",IOUOFF,!
QUIT
End DoDot:2
DO DIHEAD
+34 SET ACKICDX=""
+35 SET ACKICDX=$ORDER(ACKICD(ACKI,ACKICDX))
Begin DoDot:2
+36 WRITE !,$PIECE(ACKICD(ACKI,ACKICDX),U),?15,$PIECE(ACKICD(ACKI,ACKICDX),U,3),?60,$$NUMDT^ACKQUTL($PIECE(ACKICD(ACKI,ACKICDX),U,4))
End DoDot:2
End DoDot:1
if RC<0
QUIT
+37 QUIT
+38 ;
CLASDIS ; Display Patient Servive Classifications
+1 NEW RC
+2 IF '$DATA(ACKQSER)
IF '$DATA(ACKQORG)
IF '$DATA(ACKQIR)
IF '$DATA(ACKQECON)
QUIT
+3 SET RC=$$PAGE(5)
if RC<0
QUIT
if 'RC
WRITE !!
+4 DO ENS^%ZISS
+5 WRITE IOUON,"Service Classifications",IOUOFF,!
+6 if $DATA(ACKQSER)
WRITE " SERVICE-CONNECTED "
if $DATA(ACKQORG)
WRITE " AGENT-ORANGE "
if $DATA(ACKQIR)
WRITE " RADIATION "
if $DATA(ACKQECON)
WRITE " ENVIRONMENTAL-CONTAMINANTS"
+7 WRITE !
+8 QUIT
+9 ;
+10 ;
DIHEAD WRITE !,"DIAGNOSIS",?60,"DATE ENTERED",!,$$REPEAT^XLFSTR("-",IOM-1)
+1 QUIT
+2 ;
+3 ;
ICDSORT ;
+1 SET ACKI=0
FOR
SET ACKI=$ORDER(^ACK(509850.2,DFN,1,ACKI))
if 'ACKI
QUIT
Begin DoDot:1
+2 SET ACKDC=^ACK(509850.2,DFN,1,ACKI,0)
SET ACKDD=$PIECE(ACKDC,U,2)
+3 ; returns 1 for ICD9 and 30 for ICD10
SET ACKICD=$$CSI^ICDEX(80,+ACKDC)
+4 SET ACKINFO=$$ICDDATA^ICDXCODE(ACKICD,+ACKDC,ACKDD,"I")
+5 SET ACKTGT=$PIECE(ACKINFO,U,3)
+6 SET ACKDN=$PIECE(ACKINFO,U,2)
+7 SET ACKICD(ACKDN,ACKICD)=ACKDN_U_ACKTGT_U_$$DIAGTXT^ACKQUTL8(+ACKDC,ACKDD)_U_ACKDD
End DoDot:1
+8 KILL ACKTGT,ACKMSG
+9 QUIT
+10 ;
UPDATE ; Update patient's diagnostic history in 509850.2.
+1 ; ACKDFN is defined upon entry to this module.
+2 DO WAIT^DICD
WRITE !
+3 DO PROBLIST^ACKQUTL3(ACKDFN,1)
+4 QUIT
+5 ;
+6 ;***** CHECKS IS NEW PAGE SHOULD BE STARTED
+7 ;
+8 ; [RESERVE] Number of additional reserved lines (0, by default).
+9 ; If the current page does not have so many lines
+10 ; available, a new page will be started.
+11 ;
+12 ; [FORCE] Force the prompt
+13 ;
+14 ; Return values:
+15 ;
+16 ; -2 Timeout
+17 ; -1 User canceled the output ('^' was entered)
+18 ; 0 Ok
+19 ; 1 New page
+20 ;
PAGE(RESERVE,FORCE) ;
+1 NEW RC
+2 IF ($Y'<($GET(IOSL,24)-$GET(RESERVE,1)))!$GET(FORCE)
Begin DoDot:1
+3 IF $EXTRACT(IOST,1,2)'="C-"
WRITE @IOF
QUIT
+4 NEW DA,DIR,DIROUT,DTOUT,DUOUT,I,X,Y
+5 SET DIR(0)="E"
+6 DO ^DIR
+7 SET RC=$SELECT($DATA(DUOUT):-1,$DATA(DTOUT):-2,1:1)
+8 if RC>0
WRITE @IOF
End DoDot:1
SET $Y=0
+9 QUIT +$GET(RC)
+10 ;
PRTHEAD ;
+1 SET CNTR9=0
SET CNTR0=0
+2 WRITE !,"ICD-9-CM",!
+3 FOR CNTR9=1:1
SET DATA=$GET(ACKICD9(CNTR9))
if '$DATA(ACKICD9(CNTR9))
QUIT
Begin DoDot:1
+4 SET ACKDX=$PIECE(DATA,U)
+5 SET ACKDESC=$PIECE(DATA,U,2)
+6 SET ACKDATE=$PIECE(DATA,U,3)
+7 KILL ACKICDDS,ACKARNUM
SET ACKICDDS=ACKDESC
DO BRKDESC^ACKQR3(40)
+8 ;W !,ACKDX,?15,ACKDESC,?60,ACKDATE
+9 WRITE !,ACKDX,?15,ACKICDDS(1),?60,ACKDATE
+10 FOR ACKARNM2=2:1:ACKARNUM
WRITE !?15,ACKICDDS(ACKARNM2)
+11 KILL ACKICDDS,ACKARNUM,ACKARNM2
End DoDot:1
+12 WRITE !!,"ICD-10-CM",!
+13 FOR CNTR0=1:1
SET DATA=$GET(ACKICD0(CNTR0))
if '$DATA(ACKICD0(CNTR0))
QUIT
Begin DoDot:1
+14 SET ACKDX=$PIECE(DATA,U)
+15 SET ACKDESC=$PIECE(DATA,U,2)
+16 SET ACKDATE=$PIECE(DATA,U,3)
+17 KILL ACKICDDS,ACKARNUM
SET ACKICDDS=ACKDESC
DO BRKDESC^ACKQR3(40)
+18 ;W !,ACKDX,?15,ACKDESC,?60,ACKDATE
+19 WRITE !,ACKDX,?15,ACKICDDS(1),?60,ACKDATE
+20 FOR ACKARNM2=2:1:ACKARNUM
WRITE !?15,ACKICDDS(ACKARNM2)
+21 KILL ACKICDDS,ACKARNUM,ACKARNM2
End DoDot:1
+22 QUIT
+23 ;
