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