Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACHSA6

ACHSA6.m

Go to the documentation of this file. 
  1. 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
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES
  1.  ;
  1. A1 ; Input estimated charges.
  1.  W !!,"Estimated Charges: "
  1.  I ACHSESDO]"" S X=ACHSESDO,X2="2$" D FMT^ACHS W "// "
  1.  D READ^ACHSFU
  1.  I $D(ACHSQUIT) D END^ACHSA Q
  1.  G C1^ACHSA5:$D(DUOUT)
  1.  I Y?1"?".E W "  Enter The ",$S($D(ACHSBLKF):"Dollar Amount To Be Obligated",1:"Approximate Cost of Treatment") G A1
  1.  I Y="" G A3:ACHSESDO W *7,"  Must Have Amount" G A1
  1.  S:$E(Y)="$" Y=$E(Y,2,999)
  1.  F  S %=$F(Y,",") Q:'%  S Y=$E(Y,1,%-2)_$E(Y,%,99)
  1.  I '(Y?1N.N1"."2N!(Y?1N.N))!($L(Y)>10) W *7,"  ??" G A1
  1.  S Y=$J(Y,1,2)
  1.  ;
  1.  ;GET 'NORMAL MAX' AND 'ABSOLUTE MAX' FOR OBLIGATION TYPE
  1.  S ACHS=$P($G(^ACHSF(DUZ(2),"N",ACHSTYP,0)),U,2,3)
  1.  I ACHS,Y'>ACHS S ACHSESDO=Y G A3
  1.  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
  1.  W *7 S (S,X)=Y
  1. A2 ; Confirm amount obligated.
  1.  W !!?4
  1.  S X=S,X2="2$"
  1.  D FMT^ACHS
  1.  S Y=$$DIR^XBDIR("Y","  Are You Sure This Is Correct","NO")
  1.  I $D(DTOUT) D END^ACHSA Q
  1.  G A1:$D(DUOUT),A1:'Y
  1.  S ACHSESDO=S
  1.  ;
  1. A3 ; Enter Referral Medical Priority Code
  1.  I '$$AVAIL^ACHSUUP(ACHSESDO,ACHSACFY,ACHSCFY) W !!,"This amount exceeds your funds available." G A1
  1.  W !
  1.  S DIR(0)="9002080.01,81",DIR("??")="^D DISPMPC^ACHSA6"
  1.  S:ACHSRMPC]"" DIR("B")=ACHSRMPC
  1.  D ^DIR
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  S ACHSRMPC=$G(Y)
  1.  ;
  1. A4 ; Enter additional referral data.
  1.  I (ACHSTYP=2)!$D(ACHSBLKF)!$D(ACHSSLOC) G ^ACHSA7
  1.  S Y=$$DIR^XBDIR("Y","Enter ADDITIONAL REFERRAL DATA NOW","N")
  1.  I $D(DTOUT) D END^ACHSA Q
  1.  G ^ACHSA7:'Y       ;ENTER DOCUMENTS (8/8)-(CONFIRM & RECORD)
  1.  G A1:$D(DUOUT)
  1.  D KDIR
  1.  ;
  1. RPHY ; Enter the Referral Physician.
  1.  ;MUST USE FILE 200 TO BE SAC COMPLIANT
  1.  S ACHS200=$S($G(^DD(9002080.01,80,0))["VA(200,":1,1:0)
  1.  S DIC=$S(ACHS200:200,1:"^DIC(6,"),DIC(0)="AEMQZ",DIC("A")="REFERRAL PHYSICIAN: "
  1.  I 'ACHS200 S DIC("S")="I '$D(^(""I""))"
  1.  I 'ACHS200,ACHSRPHY>0 S DIC("B")=$P($G(^DIC(16,ACHSRPHY,0)),U)
  1.  D ^DIC
  1.  K DIC
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  ;S ACHSRPHY=$S($D(Y):+Y,1:"")  ;ACHS*3.1*19
  1.  S ACHSRPHY=$S(+Y>0:+Y,1:"")   ;ACHS*3.1*19
  1.  ;
  1. RCOI ; Enter Referral Cause Of Injury.;ACHS*3.1*23 MODIFIED ENTIRE SECTION TO USE LEXICON
  1.  ;S DIR(0)="9002080.01,82"
  1.  ;S:ACHSRCOI]"" DIR("B")=$P(ACHSRCOI,U,2)
  1.  ;D ^DIR
  1.  ;G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  ;D KDIR
  1.  ;S ACHSRCOI=$G(Y)
  1.  I ACHSEDOS<$$IMPDATE^LEXU("10D") S (ACHSICD,ACHSICD1)="ICD"
  1.  E  S (ACHSICD,ACHSICD1)="10D"
  1.  S ACHSLEX=+($$CSYS^LEXU(ACHSICD)) ;Get Coding System
  1.  D CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
  1.  S DIC("A")="Referral Cause of Injury ICD DX code: "
  1.  K X D ^LEXA1 I +Y>0 S ACHSRCOI=$P($$CODEN^ICDEX($G(Y(+ACHSLEX)),80),"~")
  1.  K Y,X,LEXQ,LEXVDT,ICDV,DIC
  1.  ;
  1. RALR ; Enter Referral Alcohol Related?.
  1.  W !
  1.  S DIR(0)="9002080.01,83"
  1.  S:ACHSRALR]"" DIR("B")=ACHSRALR
  1.  D ^DIR
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  S ACHSRALR=$G(Y)
  1.  ;
  1. RDX ; Enter Referral ICD DX codes.;ACHS*3.1*23 MODIFIED ENTIRE SECTION
  1.  ;S DIR(0)="9002080.184,.01"
  1.  ;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
  1.  ;I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRDX(%))  K ACHSRDX(%)
  1.  ;G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  ;D KDIR
  1.  F ACHS=1:1 W ! D  Q:+Y<0
  1.  .D CONFIG^LEXSET(ACHSICD,ACHSICD1,ACHSEDOS)
  1.  .S DIC("A")="Referral DX # "_ACHS_": " K X D ^LEXA1 Q:+Y<0
  1.  .S ACHSRDX(ACHS)=$P($$CODEN^ICDEX($G(Y(+ACHSLEX)),80),"~")
  1.  .K LEXQ,LEXVDT
  1.  K ACHSICD,ACHSICD1,ACHSLEX,Y,X,LEXQ,LEXVDT,ICDV,ACHSQ,DIC
  1.  ;ACHS*3.1*23 END OF ICD10 CHANGES
  1.  ;
  1. RDXN ; Enter Referral Diagnosis (DX) Narrative.
  1.  S DIR(0)="9002080.01,85"
  1.  S:ACHSRDXN]"" DIR("B")=ACHSRDXN
  1.  D ^DIR
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  S ACHSRDXN=$G(Y)
  1.  ;
  1. RPX ; Enter Referral ICD PROCEDURE codes.
  1.  ;3.1*14 12.4.2007 IHS/OIT/FCJ ADDED CSV CHANGES NXT 2 LINES
  1.  ;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))
  1.  ;ACHS*3.1*23
  1.  ;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))
  1.  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))
  1.  S DIR(0)="9002080.186,.01"
  1.  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
  1.  I $D(DUOUT)!(X="@") F %=ACHS:1 Q:'$D(ACHSRPX(%))  K ACHSRPX(%)
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  ;
  1. RPXN ; Enter Referral Procedure (PX) Narrative.
  1.  S DIR(0)="9002080.01,87"
  1.  S:ACHSRPXN]"" DIR("B")=ACHSRPXN
  1.  D ^DIR
  1.  G A1:$D(DUOUT),KDIR:$D(DTOUT)
  1.  D KDIR
  1.  S ACHSRPXN=$G(Y)
  1.  G ^ACHSA7
  1.  ;
  1.  ;
  1. KDIR ;
  1.  K DIR,DIRUT
  1.  W !!
  1.  Q
  1.  ;
  1. DISPMPC ;EP - From call to DIR, display medical priorities
  1.  W !!
  1.  S %=0
  1.  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...")
  1.  Q
  1.  ;
  1. NODE ;EP - To set 0th node of Referral medical data multiples.
  1.  ; Called from ^ACHSA7.  Here because of size of ACHSA7.
  1.  ; ACHSDIEN must be defined.
  1.  I $D(ACHSRDX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,4,0)=$$ZEROTH^ACHS(9002080,100,84)
  1.  I $D(ACHSRPX) S:'$D(^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)) ^ACHSF(DUZ(2),"D",ACHSDIEN,6,0)=$$ZEROTH^ACHS(9002080,100,86)
  1.  Q
  1.  ;