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

ACHSDNL2.m

Go to the documentation of this file. 
  1. ACHSDNL2 ; IHS/ITSC/PMF - DENIAL LTR/FS (LTR1) (3/6) ;    [ 01/05/2005  8:25 AM ]
  1.  ;;3.1;CONTRACT HEALTH MGMT SYSTEM;**3,4,6,7,12,18,22**;JUNE 11,2001;Build 13
  1.  ;ACHS*3.1*3  new method of displaying chart number
  1.  ;ACHS*3.1*4  allow multiple office copies
  1.  ;ACHS*3.1*6  3.27.03 IHS/SET/FCJ print vendor amount and other resource
  1.  ;ACHS*3.1*6  3.27.03 IHS/SET/FCJ Need X var for format change to ACHSA1
  1.  ;ACHS*3.1*7  11.4.03 IHS/SET/JVK Fix Print of Est. Act. for Provider
  1.  ;ACHS*3.1*12  1.4.04 IHS/SET/JVK  ADD CHECK FOR PAWNEE BEN PKG
  1.  ;ACHS*3.1*18 6.11.10 IHS/SET/ABK  ADD Top, REV and Left Margin parameter fetches, 
  1.  ;                                 and implement.
  1.  ;
  1.  ;{ABK, 6/11/10} SET TOPM AND DIWL FROM CHS DENIAL PARAMETERS
  1.  S T2=$G(^ACHSDENR(DUZ(2),0)),DIWL=$P(T2,U,9),TOPM=$P(T2,U,11)
  1.  S:DIWL="" DIWL=5 S:TOPM="" TOPM=5
  1.  ;{ABK, 6/11/10}S DIWR=79,DIWL=5,DIWF="NW"
  1.  S DIWR=79,DIWF="NW"
  1.  D HEADER
  1. START ;
  1.  N ACHDNAMV
  1.  ;
  1.  ;ACHS*3.1*4  4/5/02  pmf
  1.  ;I $D(ACHDONE) W ! F I=1:1:4 W "*** OFFICE COPY *** "  ; ACHS*3.1*4
  1.  I 'ACHDONE W ! F I=1:1:4 W "*** OFFICE COPY *** "  ; ACHS*3.1*4
  1.  ;
  1.  I $$DN^ACHS(0,8)="Y" W ! F I=1:1:4 W "DOCUMENT CANCELLED *"
  1.  W !!!
  1.  S ACHSCNT=0
  1.  S ACHSPG=1
  1. DATE ;
  1.  W !!,?DIWL-1,$$FMTE^XLFDT($$DN^ACHS(0,2)),!!
  1.  I '$D(ACHDCPAT) W !?DIWL-1,ACHDNAME D:ACHDONFL ADDR^ACHSDNL5 S:'ACHDONFL X=ACHDADDR D:'ACHDONFL SUBADDR^ACHSDNL5 W !!?DIWL-1,"The following letter was sent to the patient for denial of service:",!!
  1.  S X="Document number: "_$$DN^ACHS(0,1)
  1.  W ?76-$L(X),X,!!
  1.  ;
  1.  ;LET'S SEE IF WE NEED TO SEND THIS TO AN 'SEND LETTER TO PATIENT?'"
  1.  ;
  1.  S ACHDALT=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,9)),U)
  1.  I ACHDALT="N" D ALTREC ;CONTINUE TO SEE IF PATIENT REGISTERED OR NOT
  1.  ;
  1.  G NOT:'($$DN^ACHS(0,6)="Y")     ;'IS THIS PATIENT REGISTERED?'
  1.  ;
  1.  ;GET REGISTERED PATIENT INFO
  1.  S DFN=$$DN^ACHS(0,7)
  1.  I DFN']"" D END Q
  1.  I '$D(^DPT(DFN,0)) D END Q
  1.  ;
  1.  S ACHDNAMP=$P($G(^DPT(DFN,0)),U)
  1.  S ACHDNAMP=$P(ACHDNAMP,",",2,99)_" "_$P(ACHDNAMP,",",1)
  1.  ;
  1.  ;S ACHDCH="CHART #: "  ; ACHS*3.1*3
  1.  ;S:$D(^AUPNPAT(DFN,41,DUZ(2),0)) ACHDCH=ACHDCH_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)_" "_$P($G(^DIC(4,DUZ(2),0)),U)  ; ACHS*3.1*3
  1.  ;I '$D(^AUPNPAT(DFN,41,DUZ(2),0)) S ACHDCH=ACHDCH_"(No Chart At This Facility)"  ; ACHS*3.1*3
  1.  D SETCHT  ; ACHS*3.1*3
  1.  ;
  1.  I ACHDALT="N" G DEMO
  1.  W !?4,"TO: "
  1.  W ?8,ACHDNAMP        ;,?76-$L(ACHDCH),ACHDCH,!
  1.  S A=$G(^DPT(DFN,.11))
  1.  W !?8,$P(A,U)
  1.  W !?8,$P(A,U,4),","
  1.  S ACHDST=$P(A,U,5)
  1.  I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
  1.  W " ",$P(A,U,6),!!
  1.  G DEMO
  1.  ;
  1.  ;GET NON-REGISTERED PATIENT INFO
  1. NOT ;
  1.  ;1/8/02  pmf  dont go date, quit instead
  1.  ;I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,10)) W "(No patient on file)" G DATE  ; ACHS*3.1*3
  1.  I '$D(^ACHSDEN(DUZ(2),"D",ACHSA,10)) W "(No patient on file)" Q  ; ACHS*3.1*3
  1.  S A=$G(^ACHSDEN(DUZ(2),"D",ACHSA,10))
  1.  S X=$P(A,U)
  1.  S ACHDNAMP=$P(X,",",2,99)_" "_$P(X,",")
  1.  S:$E(ACHDNAMP)=" " ACHDNAMP=$E(ACHDNAMP,2,100)
  1.  ;
  1.  ;S ACHDCH=$P(A,U,6)  ; ACHS*3.1*3
  1.  ;S:ACHDCH']"" ACHDCH="(No Chart At This Facility)"  ; ACHS*3.1*3
  1.  ;S ACHDCH="CHART: "_ACHDCH  ; ACHS*3.1*3
  1.  D SETCHT  ; ACHS*3.1*3
  1.  ;
  1.  I ACHDALT="N" G DEMO
  1.  W !?4,"TO: "
  1.  W ?8,ACHDNAMP
  1.  W !?8,$P(A,U,2),!?8,$P(A,U,3)
  1.  S ACHDST=$P(A,U,4)
  1.  I ACHDST]"",$D(^DIC(5,ACHDST,0)) W " ",$P($G(^DIC(5,ACHDST,0)),U,2)
  1.  W " ",$P(A,U,5),!!
  1. DEMO ;
  1.  W !,?DIWL-1,"Re: Patient: ",ACHDNAMP W ?42,ACHDCH
  1.  W !?DIWL+3,"Contract Health Services request for services on ",$$FMTE^XLFDT($$DN^ACHS(0,4)),"."
  1. REQDATE ;
  1.  W !?DIWL+3,"Date request received: ",$$FMTE^XLFDT($$DN^ACHS(0,5))
  1.  K ACHDCH
  1. PROV ;
  1.  W !?DIWL+3,"Provider of services: "
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD EST/ACT CHRGS MOD BELOW MOVED INTO DO
  1.  ;I $$DN^ACHS(100,2),$D(^AUTTVNDR($$DN^ACHS(100,2),0)) W $P($G(^AUTTVNDR($$DN^ACHS(100,2),0)),U),! G OTHER
  1.  I $$DN^ACHS(100,2),$D(^AUTTVNDR($$DN^ACHS(100,2),0)) D  G OTHER
  1.  .W $P($G(^AUTTVNDR($$DN^ACHS(100,2),0)),U),!  ;ACHS*3.1*22 Add LF
  1.  .Q:$P($G(^ACHSDENR(DUZ(2),0)),U,6)="N"
  1.  .S Y=$G(^ACHSDEN(DUZ(2),"D",ACHSA,100)) I Y="" W ! Q
  1.  .S X=$P(Y,U,9) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied: ",X,"(ACT.)",! Q  ;ACHS*3.1*22 REMV LF
  1.  .S X=$P(Y,U,8) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied: ",X,"(EST.)",!    ;ACHS*3.1*22 REMV LF
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ END OF CHANGES
  1.  ;ACHS*3.1*7 11/4/03 ITSC/SET/JVK FIX PRINT EST AND ACT AMTS.
  1.  ;COMMENT LINE BELOW ADD DO LOOP
  1.  ;I $$DN^ACHS(100,1)="N" S ACHDNAMV=$$DN^ACHS(100,3) D VNAM W ?DIWL+3,ACHDNAMV,?60,"$",$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,8),$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,9),!
  1.  ;
  1.  I $$DN^ACHS(100,1)="N" S ACHDNAMV=$$DN^ACHS(100,3) D VNAM W ?DIWL+3,ACHDNAMV D
  1.  .W:$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,8) ?60,"$",($P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,8)),! Q
  1.  .W:$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,9) ?60,"$",$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,100)),U,9),! Q
  1.  .W ! Q
  1.  ;ACHS*3.1*7 11/4/03 ITSC/SET/JVK END FIX PRINT OF EST AND ACT AMTS.
  1.  ;
  1.  ;ARE THERE 'OTHER PROVIDER ON-FILE'
  1. OTHER ;
  1.  G OTHER1:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,200,0))
  1.  G OTHER1:+$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,0)),U,4)=0
  1.  ;
  1.  S ACHSCNT=1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD VAR TEST>1 ITEMS TO TOTAL
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGING X TO ACHSA1 IN NEXT 3 LINES
  1.  S ACHSA1=0
  1.  F  S ACHSA1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHSA1)) Q:+ACHSA1=0  D
  1.  .S Y=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHSA1,0)),U) I Y="" W ! Q
  1.  .I Y,$D(^AUTTVNDR(Y,0)) W !?DIWL+3,"Provider of services: ",$P($G(^AUTTVNDR(Y,0)),U),!
  1.  .;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED NXT 4 LNES TO PRT EST. AND ACT. CHARGES
  1.  .Q:$P($G(^ACHSDENR(DUZ(2),0)),U,6)="N"
  1.  .S TMP=$G(^ACHSDEN(DUZ(2),"D",ACHSA,200,ACHSA1,0))
  1.  .S X=$P(TMP,U,3) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied:  ",X,"(ACT.)",! Q
  1.  .S X=$P(TMP,U,2) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied:  ",X,"(EST.)",!
  1.  ;
  1.  ;ARE THERE 'OTHER PROVIDER (NOT ON-FILE)'
  1. OTHER1 ;
  1.  G O:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,210,0))
  1.  G O:+$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,0)),U,4)=0
  1.  ;
  1.  S ACHSCNT=1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD VAR TEST>1 ITEMS TO TOTAL
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGING X TO ACHSA1 IN NEXT 3 LINES
  1.  S ACHSA1=0
  1.  F  S ACHSA1=$O(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHSA1)) Q:+ACHSA1=0  D
  1.  .S ACHDNAMV=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHSA1,0)),U)
  1.  .D VNAM
  1.  .W ?DIWL+3,"Provider of services: ",ACHDNAMV,!
  1.  .;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED NXT 4 LINES ACT. AND EST CHARGES
  1.  .Q:$P($G(^ACHSDENR(DUZ(2),0)),U,6)="N"
  1.  .S Y=$G(^ACHSDEN(DUZ(2),"D",ACHSA,210,ACHSA1,0)) Q:Y=""
  1.  .S X=$P(Y,U,7) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied: ",X,"(ACT.)",! Q
  1.  .S X=$P(Y,U,6) I X]"" S X2="2$" D COMMA^%DTC W ?10,"Amount Denied: ",X,"(EST.)",!
  1.  ;
  1.  ;ARE THERE 'OTHER RESOURCES' ?
  1. O ;
  1.  ;
  1.  ;IS THE 'OTHER RESOURCES' SUBFILE 0 NODE THERE? IF NOT GO TO BODY
  1.  G BODY^ACHSDNL3:'$D(^ACHSDEN(DUZ(2),"D",ACHSA,800,0))
  1.  ;
  1.  ;ARE THER ENTRIES IN THIS SUBFILE? IF NOT GO TO BODY 
  1.  G BODY^ACHSDNL3:+$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,0)),U,3)=0
  1.  S (Y,A)=0
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED LINE FEED
  1.  ;W ?DIWL+3,"Other resources: "   ;ACHS*3.1*6
  1.  W !?DIWL+3,"Other resources: "   ;ACHS*3.1*6
  1. O1 ;
  1.  S A=$O(^ACHSDEN(DUZ(2),"D",ACHSA,800,A))
  1.  W:'A !
  1.  G BODY^ACHSDNL3:+A=0
  1.  S ACHSCNT=1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADD VAR TEST >1 ITEM TO TOTAL
  1.  S %=$P($G(^ACHSDEN(DUZ(2),"D",ACHSA,800,A,0)),U)
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGING X TO ACHSA1 IN NEXT 3 LINES
  1.  ;S X=$S(%'?1.N:%,1:$P($G(^AUTNINS(%,0)),U)) 
  1.  S ACHSA1=$S(%'?1.N:%,1:$P($G(^AUTNINS(%,0)),U))
  1.  ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED AMT TO PRINT MOVED TO DO 
  1.  ;I $X+$L(X)<77 W:Y ", " W X S Y=1 G O1
  1.  I $X+$L(ACHSA1)<77 D  G O1
  1.  .W !?DIWL+4,ACHSA1
  1.  .S X=$P(^ACHSDEN(DUZ(2),"D",ACHSA,800,A,0),U,2)
  1.  .I X]"" S X2="2$" D COMMA^%DTC W !,?10,"Other resources paid: ",X
  1.  .I X="" W !,?10,"Other resources paid: $0.00"
  1.  .S Y=1
  1.  ;W ",",!?26,X G O1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGE X TO ACHSA1
  1.  W !?26,ACHSA1 G O1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ CHANGE X TO ACHSA1 REMOVED ","
  1.  G ^ACHSDNL3
  1.  ;
  1.  ;PRINT OUT THE 'ALTERNATE RECIPIENT' ADDRESS
  1. ALTREC ;
  1.  W !?4,"TO: "
  1.  S ACHDLINE=0
  1.  F X=1:1 S ACHDLINE=$O(^ACHSDEN(DUZ(2),"D",ACHSA,9.5,ACHDLINE)) Q:+ACHDLINE=0  D
  1.  .S:X=1 ACHDALTN=$G(^ACHSDEN(DUZ(2),"D",ACHSA,9.5,ACHDLINE,0))
  1.  .W:X'=1 !
  1.  .W ?8,$G(^ACHSDEN(DUZ(2),"D",ACHSA,9.5,ACHDLINE,0))
  1.  W !!
  1.  Q
  1. END ;
  1.  Q:$G(ACHSQUIT)
  1.  D RTRN^ACHS
  1.  W @IOF
  1.  ;K A,DTOUT,DUOUT ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED TMP AND ACHSA1
  1.  K A,DTOUT,DUOUT,TMP,ACHSA1 ;ACHS*3.1*6 3.27.03 IHS/SET/FCJ ADDED TMP AND ACHSA1
  1.  Q
  1.  ;
  1. VNAM ;
  1.  Q:ACHDNAMV'[","
  1.  S ACHDNAM1=$P(ACHDNAMV,",",3)
  1.  S ACHDNAMV=$P(ACHDNAMV,",",2)_" "_$P(ACHDNAMV,",",1)_" "_$S($D(ACHDNAM1):ACHDNAM1,1:"")
  1.  K ACHDNAM1
  1.  Q
  1.  ;
  1.  ;
  1.  Q:'$D(^ACHSDENR(DUZ(2),5))               ;QUIT IF NO 'HEADER' FOUND
  1.  Q:$P($G(^ACHSDENR(DUZ(2),0)),U,7)'="Y"   ;'USER LETTERHEAD' NO
  1.  F ACHD=0:0 S ACHD=$O(^ACHSDENR(DUZ(2),5,ACHD)) Q:+ACHD=0  S X=$G(^ACHSDENR(DUZ(2),5,ACHD,0)) D ^DIWP
  1.  D ^DIWW
  1.  Q
  1.  ;
  1. SETCHT ;EP - FROM ACHSDNL3
  1.  ;ACHS*3.1*3  entire module is new
  1.  ;set the variable that prints the CHART number.  There are several
  1.  ;possibilities, including one that is special for the Pawnee facility.
  1.  ;
  1.  ;start with the name of the datum
  1.  S ACHDCH="CHART: "
  1.  ;next, see if the patient is registered.
  1.  ;If so, then use the chart number from AUPNPAT
  1.  ;If there isn't one, say NO CHART
  1.  I ($$DN^ACHS(0,6)="Y") D
  1.  . I $D(^AUPNPAT(DFN,41,DUZ(2),0)) S ACHDCH=ACHDCH_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)_" "_$P($G(^DIC(4,DUZ(2),0)),U) Q
  1.  . S ACHDCH=ACHDCH_"(No Chart At This Facility)"
  1.  . Q
  1.  ;
  1.  ;If the patient is not registered, then set it based on what's
  1.  ;found in the denial data
  1.  I ($$DN^ACHS(0,6)'="Y") D
  1.  . N DAT
  1.  . S DAT=$G(^ACHSDEN(DUZ(2),"D",ACHSA,10))
  1.  . I $P(DAT,U,6)'="" S ACHDCH=ACHDCH_$P(DAT,U,6) I 1
  1.  . E  S ACHDCH=ACHDCH_"(No Chart At This Facility)"
  1.  . Q
  1.  ;
  1.  ;now, if this is not the Pawnee facility, quit.
  1.  ;if it is, add the BP number onto the end
  1.  I $P(^AUTTLOC($S($G(ACHSFAC)'="":ACHSFAC,1:DUZ(2)),0),U,10)'=505613 Q
  1.  S ACHDCH=ACHDCH_"  BP#: "
  1.  ;ITSC/SET/JVK ACHS*3.1*12 ADD FOR IHS/OKCAO/POC PAWNEE BEN PKG
  1.  ;S ACHSBPNO=$P($G(^AZOPBPP(DFN,0)),U,2)
  1.  I '$G(DFN) S ACHSBPNO="NONE"
  1.  E  S ACHSBPNO=$P($G(^AZOPBPP(DFN,0)),U,2)
  1.  ;END CHANGES ACHS*3.1*12
  1.  S ACHSCH=ACHDCH_" "_ACHSBPNO
  1.  Q