AUPNSICH ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ;
;;2.0;IHS PCC SUITE;**2,10,11,16**;MAY 14, 2009;Build 9
;IHS/TUCSON/LAB - added checks for filegram and CHS, do not
;
HELP ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
S %="Enter an active "_$S(I=1:"ICD-9-CM",1:"ICD-10-CM")_" diagnosis code or descriptive text. "
D EN^DDIOL(%)
I I=1 D
.D EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of"),EN^DDIOL("Morbidity codes).")
.;D EN^DDIOL(" ")
I I=30 D
.D EN^DDIOL("DO NOT enter a code that begins with V, W, X or Y (these are External"),EN^DDIOL("cause of Morbidity codes).")
.;D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
;ASK FOR LIST
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80,"*","CODE",AUPNC)
;display to screen until "^"
NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
.I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
.;CHECK FOR ACTIVE STATUS
.S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
.I I=1 Q:$E(AUPNX)="E"
.I I=30,$E($P(%,U,2),1)="V" Q
.I I=30,$E($P(%,U,2),1)="W" Q
.I I=30,$E($P(%,U,2),1)="X" Q
.I I=30,$E($P(%,U,2),1)="Y" Q
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,4)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
ASKLIST() ;
NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="Do you want the entire ICD DIAGNOSIS List",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q 0
I 'Y Q 0
Q 1
ASKLISTO() ;
NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
S DIR(0)="Y",DIR("A")="Do you want the entire ICD OPERATION/PROCEDURE List",DIR("B")="N" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q 0
I 'Y Q 0
Q 1
HELPFH ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Family History Diagnosis code. "
;D EN^DDIOL(%)
D EN^DDIOL(" ")
I I=1 D
.D EN^DDIOL("Enter the Family History ICD that best describes the diagnosis."),EN^DDIOL("Select an active code, must be V16*, V17*, V18* or V19*.")
.D EN^DDIOL(" ")
I I=30 D
.D EN^DDIOL("Enter the Family History ICD that best describes the diagnosis."),EN^DDIOL("Select an active code in the Z80 to Z84 range.")
.D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80,$S(I=1:"V16-V19.Z",1:"Z80-Z84.ZZZZ"),"CODE",AUPNC)
;display to screen until "^"
NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
.I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
.;CHECK FOR ACTIVE STATUS
.S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,4)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
HELPE ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
I I=1 D Q
.D EN^DDIOL("Enter a cause of injury ""E"" code.")
.D EN^DDIOL(" ")
.;Q:X="?"
.Q:X="?BAD"
.Q:'$$ASKLIST()
.NEW AUPNC
.K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
.D LST^ATXAPI(1,80,"E*","CODE",AUPNC)
.;display to screen until "^"
.NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
.S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
..I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
..;CHECK FOR ACTIVE STATUS
..S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
..Q:'$P(%,U,10) ;inactive on this date
..S X=AUPNX,$E(X,12)=$P(%,U,4)
..D EN^DDIOL(X)
..S AUPNF=1
.K ^TMP($J,"APCDCODE")
I I=30 D Q
.D EN^DDIOL("Must be an external cause of morbidity code. The code range is V00-Y99.")
.D EN^DDIOL(" ")
.;Q:X="?"
.Q:X="?BAD"
.Q:'$$ASKLIST()
.NEW AUPNC
.K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
.D LST^ATXAPI(30,80,"V01-Y99.Z","CODE",AUPNC)
.;display to screen until "^"
.NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
.S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
..I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
..;CHECK FOR ACTIVE STATUS
..S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
..Q:'$P(%,U,10) ;inactive on this date
..S X=AUPNX,$E(X,12)=$P(%,U,4)
..D EN^DDIOL(X)
..S AUPNF=1
.K ^TMP($J,"APCDCODE")
Q
EOP ;
S AUPNQ=0
NEW DIR
NEW DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
S DIR(0)="E" D ^DIR K DIR
I $D(DUOUT) S AUPNQ=1 Q
W:$D(IOF) @IOF
Q
;
HELPPL ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code. "
I I=30 D EN^DDIOL(%)
I I=1 D Q
.D EN^DDIOL("Enter a Place or Occurrence code in the range E849.0-E849.9.")
.D EN^DDIOL(" ")
.;Q:X="?"
.Q:X="?BAD"
.Q:'$$ASKLIST()
.NEW AUPNC
.K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
.D LST^ATXAPI(1,80,"E849-E849.ZZ","CODE",AUPNC)
.;display to screen until "^"
.NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
.S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
..I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
..;CHECK FOR ACTIVE STATUS
..S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
..Q:'$P(%,U,10) ;inactive on this date
..S X=AUPNX,$E(X,12)=$P(%,U,4)
..D EN^DDIOL(X)
..S AUPNF=1
.K ^TMP($J,"APCDCODE")
I I=30 D Q
.D EN^DDIOL("Must be in the code range Y92-Y92.9.")
.D EN^DDIOL(" ")
.;Q:X="?"
.Q:X="?BAD"
.Q:'$$ASKLIST()
.NEW AUPNC
.K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
.D LST^ATXAPI(30,80,"Y92-Y92.ZZ","CODE",AUPNC)
.;display to screen until "^"
.NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
.S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
..I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
..;CHECK FOR ACTIVE STATUS
..S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
..Q:'$P(%,U,10) ;inactive on this date
..S X=AUPNX,$E(X,12)=$P(%,U,4)
..D EN^DDIOL(X)
..S AUPNF=1
.K ^TMP($J,"APCDCODE")
Q
HELPOP ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80.1,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMPOP^AUPNSICD(D) ;get ien of coding system
S %="Enter an active "_$S(I=2:"ICD-9",1:"ICD-10")_" Procedure Code or descriptive text. "
D EN^DDIOL(%)
;D EN^DDIOL("Enter a Procedure name (2-245 characters in length), a Procedure")
;D EN^DDIOL("code, one or more keywords sufficient to select a Procedure name.")
;D EN^DDIOL(" ")
;Q:X="?"
Q:X="?BAD"
Q:'$$ASKLISTO()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80.1,"*","CODE",AUPNC)
;display to screen until "^"
NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
.I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
.;CHECK FOR ACTIVE STATUS
.S %=$$ICDOP^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,5)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
HELPRFB ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code. "
;D EN^DDIOL(%)
I I=1 Q
I I=30 D Q
.D EN^DDIOL("Must be in the code range Z18-Z18.9.")
.D EN^DDIOL(" ")
.;Q:X="?"
.Q:X="?BAD"
.Q:'$$ASKLIST()
.NEW AUPNC
.K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
.D LST^ATXAPI(30,80,"Z18-Z18.Z","CODE",AUPNC)
.;display to screen until "^"
.NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
.S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
..I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
..;CHECK FOR ACTIVE STATUS
..S %=$$ICDDX^ICDEX($P(^TMP($J,"APCDCODE",AUPNX),U,1),D,,"I")
..Q:'$P(%,U,10) ;inactive on this date
..S X=AUPNX,$E(X,12)=$P(%,U,4)
..D EN^DDIOL(X)
..S AUPNF=1
.K ^TMP($J,"APCDCODE")
Q
HELPLEX ;EP
NEW D,I,%
S D=""
I '$O(^ICDS("F",80,0)) Q
I $T(LST^ATXAPI)="" Q
I $G(APCDVSIT),$D(^AUPNVSIT(APCDVSIT)) D
.I $P(^AUPNVSIT(APCDVSIT,0),U,7)="H",$$DSCHDATE^APCLV(APCDVSIT)]"" S D=$$DSCHDATE^APCLV(APCDVSIT) Q
.S D=$P($P(^AUPNVSIT(APCDVSIT,0),U),".")
I D="" S D=$P($G(APCDDATE),".")
I D="" S D=DT
S I=$$IMP^AUPNSICD(D) ;get ien of coding system
;Q:X="?"
Q:X="?BAD"
Q:'$$ASKLIST()
NEW AUPNC
K ^TMP($J,"APCDCODE") S AUPNC=$NA(^TMP($J,"APCDCODE"))
D LST^ATXAPI(I,80,"*","CODE",AUPNC)
;display to screen until "^"
NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
S AUPNX="",AUPNQ=0,AUPNF=0 F S AUPNX=$O(^TMP($J,"APCDCODE",AUPNX)) Q:AUPNX=""!($G(AUPNQ)) D
.I AUPNF,$Y>(IOSL-2) D EOP Q:AUPNQ
.;CHECK FOR ACTIVE STATUS
.I I=1 Q:$E(AUPNX)="E"
.I I=30,$E($P(%,U,2),1)="V" Q
.I I=30,$E($P(%,U,2),1)="W" Q
.I I=30,$E($P(%,U,2),1)="X" Q
.I I=30,$E($P(%,U,2),1)="Y" Q
.S %=$$ICDDX^ICDEX($P(AUPNC(AUPNX),U,1),D)
.Q:'$P(%,U,10) ;inactive on this date
.S X=AUPNX,$E(X,12)=$P(%,U,4)
.D EN^DDIOL(X)
.S AUPNF=1
K ^TMP($J,"APCDCODE")
Q
AUPNSICH ; IHS/CMI/LAB - Screen Purpose of Visit/ICD9 codes 24-MAY-1993 ;
+1 ;;2.0;IHS PCC SUITE;**2,10,11,16**;MAY 14, 2009;Build 9
+2 ;IHS/TUCSON/LAB - added checks for filegram and CHS, do not
+3 ;
HELP ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 SET %="Enter an active "_$SELECT(I=1:"ICD-9-CM",1:"ICD-10-CM")_" diagnosis code or descriptive text. "
+12 DO EN^DDIOL(%)
+13 IF I=1
Begin DoDot:1
+14 DO EN^DDIOL("DO NOT enter a code that begins with E (these are External cause of")
DO EN^DDIOL("Morbidity codes).")
+15 ;D EN^DDIOL(" ")
End DoDot:1
+16 IF I=30
Begin DoDot:1
+17 DO EN^DDIOL("DO NOT enter a code that begins with V, W, X or Y (these are External")
DO EN^DDIOL("cause of Morbidity codes).")
+18 ;D EN^DDIOL(" ")
End DoDot:1
+19 ;Q:X="?"
+20 IF X="?BAD"
QUIT
+21 ;ASK FOR LIST
+22 IF '$$ASKLIST()
QUIT
+23 NEW AUPNC
+24 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+25 DO LST^ATXAPI(I,80,"*","CODE",AUPNC)
+26 ;display to screen until "^"
+27 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+28 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+29 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+30 ;CHECK FOR ACTIVE STATUS
+31 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+32 IF I=1
IF $EXTRACT(AUPNX)="E"
QUIT
+33 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT
+34 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT
+35 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT
+36 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT
+37 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+38 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+39 DO EN^DDIOL(X)
+40 SET AUPNF=1
End DoDot:1
+41 KILL ^TMP($JOB,"APCDCODE")
+42 QUIT
ASKLIST() ;
+1 NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want the entire ICD DIAGNOSIS List"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT 0
+4 IF 'Y
QUIT 0
+5 QUIT 1
ASKLISTO() ;
+1 NEW X,Y,%,I,D,DIR,DIE,DA,DIC,DIRUT,DUOUT
+2 SET DIR(0)="Y"
SET DIR("A")="Do you want the entire ICD OPERATION/PROCEDURE List"
SET DIR("B")="N"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT 0
+4 IF 'Y
QUIT 0
+5 QUIT 1
HELPFH ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 ;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Family History Diagnosis code. "
+12 ;D EN^DDIOL(%)
+13 DO EN^DDIOL(" ")
+14 IF I=1
Begin DoDot:1
+15 DO EN^DDIOL("Enter the Family History ICD that best describes the diagnosis.")
DO EN^DDIOL("Select an active code, must be V16*, V17*, V18* or V19*.")
+16 DO EN^DDIOL(" ")
End DoDot:1
+17 IF I=30
Begin DoDot:1
+18 DO EN^DDIOL("Enter the Family History ICD that best describes the diagnosis.")
DO EN^DDIOL("Select an active code in the Z80 to Z84 range.")
+19 DO EN^DDIOL(" ")
End DoDot:1
+20 ;Q:X="?"
+21 IF X="?BAD"
QUIT
+22 IF '$$ASKLIST()
QUIT
+23 NEW AUPNC
+24 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+25 DO LST^ATXAPI(I,80,$SELECT(I=1:"V16-V19.Z",1:"Z80-Z84.ZZZZ"),"CODE",AUPNC)
+26 ;display to screen until "^"
+27 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+28 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+29 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+30 ;CHECK FOR ACTIVE STATUS
+31 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+32 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+33 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+34 DO EN^DDIOL(X)
+35 SET AUPNF=1
End DoDot:1
+36 KILL ^TMP($JOB,"APCDCODE")
+37 QUIT
HELPE ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 IF I=1
Begin DoDot:1
+12 DO EN^DDIOL("Enter a cause of injury ""E"" code.")
+13 DO EN^DDIOL(" ")
+14 ;Q:X="?"
+15 IF X="?BAD"
QUIT
+16 IF '$$ASKLIST()
QUIT
+17 NEW AUPNC
+18 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+19 DO LST^ATXAPI(1,80,"E*","CODE",AUPNC)
+20 ;display to screen until "^"
+21 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+22 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:2
+23 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+24 ;CHECK FOR ACTIVE STATUS
+25 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+26 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+27 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+28 DO EN^DDIOL(X)
+29 SET AUPNF=1
End DoDot:2
+30 KILL ^TMP($JOB,"APCDCODE")
End DoDot:1
QUIT
+31 IF I=30
Begin DoDot:1
+32 DO EN^DDIOL("Must be an external cause of morbidity code. The code range is V00-Y99.")
+33 DO EN^DDIOL(" ")
+34 ;Q:X="?"
+35 IF X="?BAD"
QUIT
+36 IF '$$ASKLIST()
QUIT
+37 NEW AUPNC
+38 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+39 DO LST^ATXAPI(30,80,"V01-Y99.Z","CODE",AUPNC)
+40 ;display to screen until "^"
+41 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+42 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:2
+43 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+44 ;CHECK FOR ACTIVE STATUS
+45 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+46 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+47 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+48 DO EN^DDIOL(X)
+49 SET AUPNF=1
End DoDot:2
+50 KILL ^TMP($JOB,"APCDCODE")
End DoDot:1
QUIT
+51 QUIT
EOP ;
+1 SET AUPNQ=0
+2 NEW DIR
+3 NEW DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
+4 SET DIR(0)="E"
DO ^DIR
KILL DIR
+5 IF $DATA(DUOUT)
SET AUPNQ=1
QUIT
+6 IF $DATA(IOF)
WRITE @IOF
+7 QUIT
+8 ;
HELPPL ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 SET %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code. "
+12 IF I=30
DO EN^DDIOL(%)
+13 IF I=1
Begin DoDot:1
+14 DO EN^DDIOL("Enter a Place or Occurrence code in the range E849.0-E849.9.")
+15 DO EN^DDIOL(" ")
+16 ;Q:X="?"
+17 IF X="?BAD"
QUIT
+18 IF '$$ASKLIST()
QUIT
+19 NEW AUPNC
+20 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+21 DO LST^ATXAPI(1,80,"E849-E849.ZZ","CODE",AUPNC)
+22 ;display to screen until "^"
+23 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+24 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:2
+25 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+26 ;CHECK FOR ACTIVE STATUS
+27 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+28 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+29 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+30 DO EN^DDIOL(X)
+31 SET AUPNF=1
End DoDot:2
+32 KILL ^TMP($JOB,"APCDCODE")
End DoDot:1
QUIT
+33 IF I=30
Begin DoDot:1
+34 DO EN^DDIOL("Must be in the code range Y92-Y92.9.")
+35 DO EN^DDIOL(" ")
+36 ;Q:X="?"
+37 IF X="?BAD"
QUIT
+38 IF '$$ASKLIST()
QUIT
+39 NEW AUPNC
+40 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+41 DO LST^ATXAPI(30,80,"Y92-Y92.ZZ","CODE",AUPNC)
+42 ;display to screen until "^"
+43 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+44 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:2
+45 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+46 ;CHECK FOR ACTIVE STATUS
+47 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+48 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+49 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+50 DO EN^DDIOL(X)
+51 SET AUPNF=1
End DoDot:2
+52 KILL ^TMP($JOB,"APCDCODE")
End DoDot:1
QUIT
+53 QUIT
HELPOP ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80.1,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMPOP^AUPNSICD(D)
+11 SET %="Enter an active "_$SELECT(I=2:"ICD-9",1:"ICD-10")_" Procedure Code or descriptive text. "
+12 DO EN^DDIOL(%)
+13 ;D EN^DDIOL("Enter a Procedure name (2-245 characters in length), a Procedure")
+14 ;D EN^DDIOL("code, one or more keywords sufficient to select a Procedure name.")
+15 ;D EN^DDIOL(" ")
+16 ;Q:X="?"
+17 IF X="?BAD"
QUIT
+18 IF '$$ASKLISTO()
QUIT
+19 NEW AUPNC
+20 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+21 DO LST^ATXAPI(I,80.1,"*","CODE",AUPNC)
+22 ;display to screen until "^"
+23 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+24 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+25 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+26 ;CHECK FOR ACTIVE STATUS
+27 SET %=$$ICDOP^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+28 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+29 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,5)
+30 DO EN^DDIOL(X)
+31 SET AUPNF=1
End DoDot:1
+32 KILL ^TMP($JOB,"APCDCODE")
+33 QUIT
HELPRFB ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 ;S %="Enter a valid "_$$VAL^XBDIQ1(80.4,I,.01)_" Place of Occurrence code. "
+12 ;D EN^DDIOL(%)
+13 IF I=1
QUIT
+14 IF I=30
Begin DoDot:1
+15 DO EN^DDIOL("Must be in the code range Z18-Z18.9.")
+16 DO EN^DDIOL(" ")
+17 ;Q:X="?"
+18 IF X="?BAD"
QUIT
+19 IF '$$ASKLIST()
QUIT
+20 NEW AUPNC
+21 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+22 DO LST^ATXAPI(30,80,"Z18-Z18.Z","CODE",AUPNC)
+23 ;display to screen until "^"
+24 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+25 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:2
+26 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+27 ;CHECK FOR ACTIVE STATUS
+28 SET %=$$ICDDX^ICDEX($PIECE(^TMP($JOB,"APCDCODE",AUPNX),U,1),D,,"I")
+29 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+30 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+31 DO EN^DDIOL(X)
+32 SET AUPNF=1
End DoDot:2
+33 KILL ^TMP($JOB,"APCDCODE")
End DoDot:1
QUIT
+34 QUIT
HELPLEX ;EP
+1 NEW D,I,%
+2 SET D=""
+3 IF '$ORDER(^ICDS("F",80,0))
QUIT
+4 IF $TEXT(LST^ATXAPI)=""
QUIT
+5 IF $GET(APCDVSIT)
IF $DATA(^AUPNVSIT(APCDVSIT))
Begin DoDot:1
+6 IF $PIECE(^AUPNVSIT(APCDVSIT,0),U,7)="H"
IF $$DSCHDATE^APCLV(APCDVSIT)]""
SET D=$$DSCHDATE^APCLV(APCDVSIT)
QUIT
+7 SET D=$PIECE($PIECE(^AUPNVSIT(APCDVSIT,0),U),".")
End DoDot:1
+8 IF D=""
SET D=$PIECE($GET(APCDDATE),".")
+9 IF D=""
SET D=DT
+10 ;get ien of coding system
SET I=$$IMP^AUPNSICD(D)
+11 ;Q:X="?"
+12 IF X="?BAD"
QUIT
+13 IF '$$ASKLIST()
QUIT
+14 NEW AUPNC
+15 KILL ^TMP($JOB,"APCDCODE")
SET AUPNC=$NAME(^TMP($JOB,"APCDCODE"))
+16 DO LST^ATXAPI(I,80,"*","CODE",AUPNC)
+17 ;display to screen until "^"
+18 NEW AUPNX,AUPNY,AUPNQ,AUPNF,X
+19 SET AUPNX=""
SET AUPNQ=0
SET AUPNF=0
FOR
SET AUPNX=$ORDER(^TMP($JOB,"APCDCODE",AUPNX))
IF AUPNX=""!($GET(AUPNQ))
QUIT
Begin DoDot:1
+20 IF AUPNF
IF $Y>(IOSL-2)
DO EOP
IF AUPNQ
QUIT
+21 ;CHECK FOR ACTIVE STATUS
+22 IF I=1
IF $EXTRACT(AUPNX)="E"
QUIT
+23 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="V"
QUIT
+24 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="W"
QUIT
+25 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="X"
QUIT
+26 IF I=30
IF $EXTRACT($PIECE(%,U,2),1)="Y"
QUIT
+27 SET %=$$ICDDX^ICDEX($PIECE(AUPNC(AUPNX),U,1),D)
+28 ;inactive on this date
IF '$PIECE(%,U,10)
QUIT
+29 SET X=AUPNX
SET $EXTRACT(X,12)=$PIECE(%,U,4)
+30 DO EN^DDIOL(X)
+31 SET AUPNF=1
End DoDot:1
+32 KILL ^TMP($JOB,"APCDCODE")
+33 QUIT
