ACHSA6 ; IHS/ITSC/TPF/PMF - ENTER DOCUMENTS (7/8)-(EST. COST, MED DATA) ;JUL 10, 2008
;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,19,23**;JUN 11,2001;Build 43
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
;
A1 ; Input estimated charges.
W !!,"Estimated Charges: "
I ACHSESDO]"" S X=ACHSESDO,X2="2$" D FMT^ACHS W "// "
D READ^ACHSFU
I $D(ACHSQUIT) D END^ACHSA Q
G C1^ACHSA5:$D(DUOUT)
I Y?1"?".E W " Enter The ",$S($D(ACHSBLKF):"Dollar Amount To Be Obligated",1:"Approximate Cost of Treatment") G A1
I Y="" G A3:ACHSESDO W *7," Must Have Amount" G A1
S:$E(Y)="$" Y=$E(Y,2,999)
F S %=$F(Y,",") Q:'% S Y=$E(Y,1,%-2)_$E(Y,%,99)
I '(Y?1N.N1"."2N!(Y?1N.N))!($L(Y)>10) W *7," ??" G A1
S Y=$J(Y,1,2)
;
;GET 'NORMAL MAX' AND 'ABSOLUTE MAX' FOR OBLIGATION TYPE
S ACHS=$P($G(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,2,3)
I ACHS,Y'>ACHS S ACHSESDO=Y G A3
I Y>$P(ACHS,U,2) W !!,*7,"The OBLIGATION LIMIT for this type of document is " S X=$P(ACHS,U,2) D FMT^ACHS W ".",!!,"Enter a lesser amount of money or exit the document.",!! G A1
W *7 S (S,X)=Y
A2 ; Confirm amount obligated.
W !!?4
S X=S,X2="2$"
D FMT^ACHS
S Y=$$DIR^XBDIR("Y"," Are You Sure This Is Correct","NO")
I $D(DTOUT) D END^ACHSA Q
G A1:$D(DUOUT),A1:'Y
S ACHSESDO=S
;
A3 ; Enter Referral Medical Priority Code
I '$$AVAIL^ACHSUUP(ACHSESDO,ACHSACFY,ACHSCFY) W !!,"This amount exceeds your funds available." G A1
W !
S DIR(0)="9002080.01,81",DIR("??")="^D DISPMPC^ACHSA6"
S:ACHSRMPC]"" DIR("B")=ACHSRMPC
D ^DIR
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
S ACHSRMPC=$G(Y)
;
A4 ; Enter additional referral data.
I (ACHSTYP=2)!$D(ACHSBLKF)!$D(ACHSSLOC) G ^ACHSA7
S Y=$$DIR^XBDIR("Y","Enter ADDITIONAL REFERRAL DATA NOW","N")
I $D(DTOUT) D END^ACHSA Q
G ^ACHSA7:'Y ;ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD)
G A1:$D(DUOUT)
D KDIR
;
RPHY ; Enter the Referral Physician.
;MUST USE FILE 200 TO BE SAC COMPLIANT
S ACHS200=$S($G(^DD(9002080.01,80,0))["VA(200,":1,1:0)
S DIC=$S(ACHS200:200,1:"^DIC(6,"),DIC(0)="AEMQZ",DIC("A")="REFERRAL PHYSICIAN: "
I 'ACHS200 S DIC("S")="I '$D(^(""I""))"
I 'ACHS200,ACHSRPHY>0 S DIC("B")=$P($G(^DIC(16,ACHSRPHY,0)),U)
D ^DIC
K DIC
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
;S ACHSRPHY=$S($D(Y):+Y,1:"") ;ACHS*3.1*19
S ACHSRPHY=$S(+Y>0:+Y,1:"") ;ACHS*3.1*19
;
RCOI ; Enter Referral Cause Of Injury.;ACHS*3.1*23 MODIFIED ENTIRE SECTION TO USE LEXICON
;S DIR(0)="9002080.01,82"
;S:ACHSRCOI]"" DIR("B")=$P(ACHSRCOI,U,2)
;D ^DIR
;G A1:$D(DUOUT),KDIR:$D(DTOUT)
;D KDIR
;S ACHSRCOI=$G(Y)
I ACHSEDOS<$$IMPDATE^LEXU("10D") S (ACHSICD,ACHSICD1)="ICD"
E S (ACHSICD,ACHSICD1)="10D"
S ACHSLEX=+($$CSYS^LEXU(ACHSICD)) ;Get Coding System
D CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
S DIC("A")="Referral Cause of Injury ICD DX code: "
K X D ^LEXA1 I +Y>0 S ACHSRCOI=$P($$CODEN^ICDEX($G(Y(+ACHSLEX)),80),"~")
K Y,X,LEXQ,LEXVDT,ICDV,DIC
;
RALR ; Enter Referral Alcohol Related?.
W !
S DIR(0)="9002080.01,83"
S:ACHSRALR]"" DIR("B")=ACHSRALR
D ^DIR
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
S ACHSRALR=$G(Y)
;
RDX ; Enter Referral ICD DX codes.;ACHS*3.1*23 MODIFIED ENTIRE SECTION
;S DIR(0)="9002080.184,.01"
;F ACHS=1:1 S DIR("A")=$P($G(^DD(9002080.184,.01,0)),U)_" # "_ACHS_" " S:$D(ACHSRDX(ACHS)) DIR("B")=$P(ACHSRDX(ACHS),U,2) D ^DIR K DIR("B") Q:$D(DIRUT) S ACHSRDX(ACHS)=Y
;I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRDX(%)) K ACHSRDX(%)
;G A1:$D(DUOUT),KDIR:$D(DTOUT)
;D KDIR
F ACHS=1:1 W ! D Q:+Y<0
.D CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
.S DIC("A")="Referral DX # "_ACHS_": " K X D ^LEXA1 Q:+Y<0
.S ACHSRDX(ACHS)=$P($$CODEN^ICDEX($G(Y(+ACHSLEX)),80),"~")
.K LEXQ,LEXVDT
K ACHSICD,ACHSICD1,ACHSLEX,Y,X,LEXQ,LEXVDT,ICDV,ACHSQ,DIC
;ACHS*3.1*23 END OF ICD10 CHANGES
;
RDXN ; Enter Referral Diagnosis (DX) Narrative.
S DIR(0)="9002080.01,85"
S:ACHSRDXN]"" DIR("B")=ACHSRDXN
D ^DIR
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
S ACHSRDXN=$G(Y)
;
RPX ; Enter Referral ICD PROCEDURE codes.
;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
;I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P($G(^ICD0(+ACHSRPX(ACHS),0)),U),1:"CPT."_$P($G(^ICPT(+ACHSRPX(ACHS),0)),U))
;ACHS*3.1*23
;I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P($$ICDOP^ICDCODE(+ACHSRPX(ACHS)),U,2),1:"CPT."_$P($$CPT^ICPTCOD(+ACHSRPX(ACHS)),U,2))
I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P($$ICDOP^ICDEX(+ACHSRPX(ACHS),,,"I"),U,2),1:"CPT."_$P($$CPT^ICPTCOD(+ACHSRPX(ACHS)),U,2))
S DIR(0)="9002080.186,.01"
F ACHS=1:1 S DIR("A")=$P($G(^DD(9002080.186,.01,0)),U)_" # "_ACHS_" " S:$D(ACHSRPX(ACHS)) DIR("B")=$P(ACHSRPX(ACHS),";") D ^DIR K DIR("B") Q:$D(DIRUT) S ACHSRPX(ACHS)=Y
I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRPX(%)) K ACHSRPX(%)
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
;
RPXN ; Enter Referral Procedure (PX) Narrative.
S DIR(0)="9002080.01,87"
S:ACHSRPXN]"" DIR("B")=ACHSRPXN
D ^DIR
G A1:$D(DUOUT),KDIR:$D(DTOUT)
D KDIR
S ACHSRPXN=$G(Y)
G ^ACHSA7
;
;
KDIR ;
K DIR,DIRUT
W !!
Q
;
DISPMPC ;EP - From call to DIR, display medical priorities
W !!
S %=0
F S %=$O(^DD(9002080.01,81,21,%)) Q:'% W !,$G(^DD(9002080.01,81,21,%,0)) I $G(^DD(9002080.01,81,21,%+1,0))[" - " Q:'$$DIR^XBDIR("E","Press RETURN...")
Q
;
NODE ;EP - To set 0th node of Referral medical data multiples.
; Called from ^ACHSA7. Here because of size of ACHSA7.
; ACHSDIEN must be defined.
I $D(ACHSRDX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
I $D(ACHSRPX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
Q
;
ACHSA6 ; IHS/ITSC/TPF/PMF - ENTER DOCUMENTS (7/8)-(EST. COST, MED DATA) ;JUL 10, 2008
+1 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**14,19,23**;JUN 11,2001;Build 43
+2 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
+3 ;
A1 ; Input estimated charges.
+1 WRITE !!,"Estimated Charges: "
+2 IF ACHSESDO]""
SET X=ACHSESDO
SET X2="2$"
DO FMT^ACHS
WRITE "// "
+3 DO READ^ACHSFU
+4 IF $DATA(ACHSQUIT)
DO END^ACHSA
QUIT
+5 IF $DATA(DUOUT)
GOTO C1^ACHSA5
+6 IF Y?1"?".E
WRITE " Enter The ",$SELECT($DATA(ACHSBLKF):"Dollar Amount To Be Obligated",1:"Approximate Cost of Treatment")
GOTO A1
+7 IF Y=""
IF ACHSESDO
GOTO A3
WRITE *7," Must Have Amount"
GOTO A1
+8 IF $EXTRACT(Y)="$"
SET Y=$EXTRACT(Y,2,999)
+9 FOR
SET %=$FIND(Y,",")
IF '%
QUIT
SET Y=$EXTRACT(Y,1,%-2)_$EXTRACT(Y,%,99)
+10 IF '(Y?1N.N1"."2N!(Y?1N.N))!($LENGTH(Y)>10)
WRITE *7," ??"
GOTO A1
+11 SET Y=$JUSTIFY(Y,1,2)
+12 ;
+13 ;GET 'NORMAL MAX' AND 'ABSOLUTE MAX' FOR OBLIGATION TYPE
+14 SET ACHS=$PIECE($GET(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,2,3)
+15 IF ACHS
IF Y'>ACHS
SET ACHSESDO=Y
GOTO A3
+16 IF Y>$PIECE(ACHS,U,2)
WRITE !!,*7,"The OBLIGATION LIMIT for this type of document is "
SET X=$PIECE(ACHS,U,2)
DO FMT^ACHS
WRITE ".",!!,"Enter a lesser amount of money or exit the document.",!!
GOTO A1
+17 WRITE *7
SET (S,X)=Y
A2 ; Confirm amount obligated.
+1 WRITE !!?4
+2 SET X=S
SET X2="2$"
+3 DO FMT^ACHS
+4 SET Y=$$DIR^XBDIR("Y"," Are You Sure This Is Correct","NO")
+5 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+6 IF $DATA(DUOUT)
GOTO A1
IF 'Y
GOTO A1
+7 SET ACHSESDO=S
+8 ;
A3 ; Enter Referral Medical Priority Code
+1 IF '$$AVAIL^ACHSUUP(ACHSESDO,ACHSACFY,ACHSCFY)
WRITE !!,"This amount exceeds your funds available."
GOTO A1
+2 WRITE !
+3 SET DIR(0)="9002080.01,81"
SET DIR("??")="^D DISPMPC^ACHSA6"
+4 IF ACHSRMPC]""
SET DIR("B")=ACHSRMPC
+5 DO ^DIR
+6 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+7 DO KDIR
+8 SET ACHSRMPC=$GET(Y)
+9 ;
A4 ; Enter additional referral data.
+1 IF (ACHSTYP=2)!$DATA(ACHSBLKF)!$DATA(ACHSSLOC)
GOTO ^ACHSA7
+2 SET Y=$$DIR^XBDIR("Y","Enter ADDITIONAL REFERRAL DATA NOW","N")
+3 IF $DATA(DTOUT)
DO END^ACHSA
QUIT
+4 ;ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD)
IF 'Y
GOTO ^ACHSA7
+5 IF $DATA(DUOUT)
GOTO A1
+6 DO KDIR
+7 ;
RPHY ; Enter the Referral Physician.
+1 ;MUST USE FILE 200 TO BE SAC COMPLIANT
+2 SET ACHS200=$SELECT($GET(^DD(9002080.01,80,0))["VA(200,":1,1:0)
+3 SET DIC=$SELECT(ACHS200:200,1:"^DIC(6,")
SET DIC(0)="AEMQZ"
SET DIC("A")="REFERRAL PHYSICIAN: "
+4 IF 'ACHS200
SET DIC("S")="I '$D(^(""I""))"
+5 IF 'ACHS200
IF ACHSRPHY>0
SET DIC("B")=$PIECE($GET(^DIC(16,ACHSRPHY,0)),U)
+6 DO ^DIC
+7 KILL DIC
+8 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+9 DO KDIR
+10 ;S ACHSRPHY=$S($D(Y):+Y,1:"") ;ACHS*3.1*19
+11 ;ACHS*3.1*19
SET ACHSRPHY=$SELECT(+Y>0:+Y,1:"")
+12 ;
RCOI ; Enter Referral Cause Of Injury.;ACHS*3.1*23 MODIFIED ENTIRE SECTION TO USE LEXICON
+1 ;S DIR(0)="9002080.01,82"
+2 ;S:ACHSRCOI]"" DIR("B")=$P(ACHSRCOI,U,2)
+3 ;D ^DIR
+4 ;G A1:$D(DUOUT),KDIR:$D(DTOUT)
+5 ;D KDIR
+6 ;S ACHSRCOI=$G(Y)
+7 IF ACHSEDOS<$$IMPDATE^LEXU("10D")
SET (ACHSICD,ACHSICD1)="ICD"
+8 IF '$TEST
SET (ACHSICD,ACHSICD1)="10D"
+9 ;Get Coding System
SET ACHSLEX=+($$CSYS^LEXU(ACHSICD))
+10 DO CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
+11 SET DIC("A")="Referral Cause of Injury ICD DX code: "
+12 KILL X
DO ^LEXA1
IF +Y>0
SET ACHSRCOI=$PIECE($$CODEN^ICDEX($GET(Y(+ACHSLEX)),80),"~")
+13 KILL Y,X,LEXQ,LEXVDT,ICDV,DIC
+14 ;
RALR ; Enter Referral Alcohol Related?.
+1 WRITE !
+2 SET DIR(0)="9002080.01,83"
+3 IF ACHSRALR]""
SET DIR("B")=ACHSRALR
+4 DO ^DIR
+5 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+6 DO KDIR
+7 SET ACHSRALR=$GET(Y)
+8 ;
RDX ; Enter Referral ICD DX codes.;ACHS*3.1*23 MODIFIED ENTIRE SECTION
+1 ;S DIR(0)="9002080.184,.01"
+2 ;F ACHS=1:1 S DIR("A")=$P($G(^DD(9002080.184,.01,0)),U)_" # "_ACHS_" " S:$D(ACHSRDX(ACHS)) DIR("B")=$P(ACHSRDX(ACHS),U,2) D ^DIR K DIR("B") Q:$D(DIRUT) S ACHSRDX(ACHS)=Y
+3 ;I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRDX(%)) K ACHSRDX(%)
+4 ;G A1:$D(DUOUT),KDIR:$D(DTOUT)
+5 ;D KDIR
+6 FOR ACHS=1:1
WRITE !
Begin DoDot:1
+7 DO CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
+8 SET DIC("A")="Referral DX # "_ACHS_": "
KILL X
DO ^LEXA1
IF +Y<0
QUIT
+9 SET ACHSRDX(ACHS)=$PIECE($$CODEN^ICDEX($GET(Y(+ACHSLEX)),80),"~")
+10 KILL LEXQ,LEXVDT
End DoDot:1
IF +Y<0
QUIT
+11 KILL ACHSICD,ACHSICD1,ACHSLEX,Y,X,LEXQ,LEXVDT,ICDV,ACHSQ,DIC
+12 ;ACHS*3.1*23 END OF ICD10 CHANGES
+13 ;
RDXN ; Enter Referral Diagnosis (DX) Narrative.
+1 SET DIR(0)="9002080.01,85"
+2 IF ACHSRDXN]""
SET DIR("B")=ACHSRDXN
+3 DO ^DIR
+4 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+5 DO KDIR
+6 SET ACHSRDXN=$GET(Y)
+7 ;
RPX ; Enter Referral ICD PROCEDURE codes.
+1 ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
+2 ;I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P($G(^ICD0(+ACHSRPX(ACHS),0)),U),1:"CPT."_$P($G(^ICPT(+ACHSRPX(ACHS),0)),U))
+3 ;ACHS*3.1*23
+4 ;I $D(ACHSRPX) F ACHS=1:1 Q:'$D(ACHSRPX(ACHS)) S ACHSRPX(ACHS)=$S(ACHSRPX(ACHS)["ICD":"ICD."_$P($$ICDOP^ICDCODE(+ACHSRPX(ACHS)),U,2),1:"CPT."_$P($$CPT^ICPTCOD(+ACHSRPX(ACHS)),U,2))
+5 IF $DATA(ACHSRPX)
FOR ACHS=1:1
IF '$DATA(ACHSRPX(ACHS))
QUIT
SET ACHSRPX(ACHS)=$SELECT(ACHSRPX(ACHS)["ICD":"ICD."_$PIECE($$ICDOP^ICDEX(+ACHSRPX(ACHS),,,"I"),U,2),1:"CPT."_$PIECE($$CPT^ICPTCOD(+ACHSRPX(ACHS)),U,2))
+6 SET DIR(0)="9002080.186,.01"
+7 FOR ACHS=1:1
SET DIR("A")=$PIECE($GET(^DD(9002080.186,.01,0)),U)_" # "_ACHS_" "
IF $DATA(ACHSRPX(ACHS))
SET DIR("B")=$PIECE(ACHSRPX(ACHS),";")
DO ^DIR
KILL DIR("B")
IF $DATA(DIRUT)
QUIT
SET ACHSRPX(ACHS)=Y
+8 IF $DATA(DUOUT)!(X="@")
FOR %=ACHS:1
IF '$DATA(ACHSRPX(%))
QUIT
KILL ACHSRPX(%)
+9 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+10 DO KDIR
+11 ;
RPXN ; Enter Referral Procedure (PX) Narrative.
+1 SET DIR(0)="9002080.01,87"
+2 IF ACHSRPXN]""
SET DIR("B")=ACHSRPXN
+3 DO ^DIR
+4 IF $DATA(DUOUT)
GOTO A1
IF $DATA(DTOUT)
GOTO KDIR
+5 DO KDIR
+6 SET ACHSRPXN=$GET(Y)
+7 GOTO ^ACHSA7
+8 ;
+9 ;
KDIR ;
+1 KILL DIR,DIRUT
+2 WRITE !!
+3 QUIT
+4 ;
DISPMPC ;EP - From call to DIR, display medical priorities
+1 WRITE !!
+2 SET %=0
+3 FOR
SET %=$ORDER(^DD(9002080.01,81,21,%))
IF '%
QUIT
WRITE !,$GET(^DD(9002080.01,81,21,%,0))
IF $GET(^DD(9002080.01,81,21,%+1,0))[" - "
IF '$$DIR^XBDIR("E","Press RETURN...")
QUIT
+4 QUIT
+5 ;
NODE ;EP - To set 0th node of Referral medical data multiples.
+1 ; Called from ^ACHSA7. Here because of size of ACHSA7.
+2 ; ACHSDIEN must be defined.
+3 IF $DATA(ACHSRDX)
IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
+4 IF $DATA(ACHSRPX)
IF '$DATA(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0))
SET ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
+5 QUIT
+6 ;
