ACRFEA4 ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA; [ 11/01/2001 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
;;CONTINUATION OF ACRFEA
CURRENT ;EP;TO CONTROL EDITING OF ACCOUNT DATA AND REQUESTS
I '$D(ACRFDNO),'$D(ACRDOCDA) S ACRQUIT="" Q
S ACRCANDA=$G(ACRCANDA)
S ACRLBOC=$G(ACRLBOC)
;IF ACRENTRY CONTAINS 'OBL' DATA BEING EDITED IS ALWAYS FOR SPECIFIC
;FINANCIAL DOCUMENT
K ACROUT
I ACRENTRY["OBL",'$D(ACRNEWOB),'$D(ACRREV),"^116^204^130^600^148^"[(U_ACRREF_U)!$D(ACRPO),'$D(ACRREACT) D Q
.D EDIT^ACRFEA41
.I "^130^600^"[(U_ACRREF_U) D RECEIPTS^ACRFSS4,TAXI^ACRFSS4
I ACRENTRY["OBL",$D(ACRDOCDA) D I '$D(ACRNEWOB) Q:$D(ACRREACT)
.I $D(^ACRAPVS("AB",ACRDOCDA)) D ^ACRFDISA
.I $D(ACRREACT) D REACT Q
.I $P(ACRDOC0,U,4)'=35 F D ACRDIE^ACRFEA2 Q:$D(ACRQUIT)!$D(ACROUT)!$D(ACRREV)!$D(ACROUT)
.Q:$D(ACROUT)
.I ACRREF=130 D 14^ACRFEA41
.K ACRQUIT
Q:$D(ACRQUIT)!$D(ACROUT)
I $D(ACRNEWOB)!$D(ACRNEW),$G(ACRREF)'=148 D EDIE1^ACRFEA2 K ACRNEW Q:$D(ACRQUIT)!$D(ACROUT)
I $D(ACRNEWOB) D
.S:'$D(ACRREFX) ACRREFX=ACRREF
.D:ACRREFX=116 EN^ACRFEA43
I ACRENTRY["OBL",$D(ACRDOCDA),'$D(ACRREV),'$D(ACRPO),$P(ACRDOC0,U,4)'=35 D
.I ACRREF'=148 D
..D SCREEN^ACRFAU
..I $D(ACRSCREN) K ACRSCREN Q
..D DISP^ACRFEA42
.N ACRI
.I ACRREF=148 D Q
..D COURSE^ACRFSS3
..D REMARKS^ACRFEA43
.D EDIE^ACRFEA2
I ACRENTRY["OBL",$D(ACRDOCDA),'$D(ACROUT) D
.D ^ACRFSS
.I $D(^ACRSS("C",ACRDOCDA)) D
..I '$D(ACRREV),$G(ACRREF)'=130,$G(ACRREF)'=148,$P(ACRDOC0,U,4)'=35 D ATTACH^ACRFEA42
..I '$D(ACRREV),'$D(ACRPO),$D(^ACRDOC(ACRDOCDA,"PO")),'$P(^ACRDOC(ACRDOCDA,"PO"),U,5) D RV^ACRFEA42
;IF ACRENTRY DOES NOT CONTAIN 'OBLA' EDITING IS ALWAYS FOR A FINANCIAL
;ACCOUNT
I ACRENTRY'["OBLA",'$D(ACRPO),'$D(ACRSS6) D S ACRQUIT="" Q
.S DA=ACRZDA
.S DIE=ACRDIE
.S DR=ACRDR
.D DDS^ACRFDIC
.I '$D(ACRSCREN),ACRENTRY'["APP" D
..S DR=$P(DR,"INFO]")_"PURPOSE]"
..D DDS^ACRFDIC
.I $D(ACRSCREN) K ACRSCREN D
..D DISP^ACRFEA42
..W !
..N ACRI
..D EDIE^ACRFEA2
.I ACRENTRY["LOCB" D
..S DIR("A")=" Edit ACCOUNT ACCESS? "
..S ACRDR="[ACR DEPARTMENT ACCT ACCESS]"
..N ACRI
..K ACRQUIT
..S DA=ACRZDA
..S DIE=ACRDIE
..S DR=ACRDR
..D DDS^ACRFDIC
..I $D(ACRSCREN) K ACRSCREN D EDIE^ACRFEA2
..D ^ACRFLBTX
.D DHR:ACRDIC["ACRALC"
Q:$D(ACROUT)
I ACRENTRY["OBL",'$D(ACRPO),'$D(ACRSS6),'$D(ACRPRT) D ASUM^ACRFEA42
I $D(ACRREV) D
.S D0=ACRDOCDA
.D ^ACRFPAPV
Q:$D(ACRREV)
D SETDOC^ACRFEA1
D ^ACRFEA41
K ACRQUIT
Q
REACT ;EP;
D OBLSTAT
Q:$D(ACRQUIT)
S DIR("A")="Return Document "_$P(ACRDOC0,U)_" to initiator ? "
W !
D OUT^ACRFEA2
Q:$D(ACROUT)!$D(ACRQUIT)
Q:ACRY'=1
S ACRTXDA=$P(ACRDOC0,U,4)
S ACRREFDA=$P(ACRDOC0,U,13)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
S ACRREF=$S("^116^204^103^349^326^210^"[(U_ACRREF_U):116,ACRREF=130:130,ACRREF=600:600,ACRREF=148:148,1:116)
I ACRREF=600 D Q:$D(ACRQUIT)
.S DIR("0")="SO^1:Reprocess TRAVEL ORDER;2:Reprocess TRAVEL VOUCHER"
.S DIR("A")="Which one"
.S DIR("B")="Reprocess TRAVEL ORDER"
.W !
.D DIR^ACRFDIC
.S:ACRY=1 ACRREF=130
S:ACRREF=600 ACRTXDA=19
S DA=ACRDOCDA
S DIE="^ACROBL("
S DR=$S(ACRREF'=600:"903///@;905///@;906///@;910///@",1:"903////A;905////A;906////Y")_";.1///"_ACRREF_";911///@;907////"_ACRTXDA
D DIE^ACRFDIC
D:ACRREF'=600 KILL^ACRFAPVS
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR=".13///"_ACRREF_";.14////"_$P($P(^ACRDOC(ACRDOCDA,0),U,14),"CANCELLED ",2)_";.2///@;.3///@;.4///@"
D DIE^ACRFDIC
S ACRREFDA=$P(^ACRDOC(ACRDOCDA,0),U,13)
D KILL^ACRFAPVS
S ACRY=1
Q
RESP ;EP;CHECK TO SEE IF RESPONSE TO APPROVAL RETURN IS REQUIRED
S ACRRESP=$G(^ACRDOC(ACRDOCDA,"DT"))
I +ACRRESP'=1!($P(ACRRESP,U,2)=1)!('$P(ACRRESP,U,10)) K ACRRESP Q
S ACREND=ACREND+1
W *7,*7
W !?5,"*** "
W ?10,ACREND
W ?15,@ACRON,"Response REQUIRED to Approval Inquiry"
W ?45,@ACROF," ***"
Q
FEDSET ;EP;
D DOC1^ACRFFS
S DA=ACRDOCDA
S DIE="^ACRDOC("
S DR="14///GSA;15///A0A;16////"_ACRFLDA_";17////"_ACRFINDA_";18////B"
D DIE^ACRFDIC
Q
DHR ;EP;DETERMINE IF ALLOWANCE DHR SHOULD BE CREATED
Q:$P($G(^ACRSYS(1,"DT1")),U,6)'=1
I '+$G(^ACRALC(ACRZDA,0)) D Q
.W !!,"This account has no dollar value to report to HAS."
.D PAUSE^ACRFWARN
I $P($G(^ACRALC(ACRZDA,0)),U,19) S ACRDHRDA=$P(^(0),U,19) D Q
.W !,"DHR ",@ACRON,$P($G(^ACRDHR(ACRDHRDA,0)),U),@ACROF," has been created for this advice of allowance."
.N DXS,DIP
.S D0=ACRDHRDA
.D ^ACRDHR
.D PAUSE^ACRFWARN
.Q:$D(ACRQUIT)
.S DIR(0)="YO"
.S DIR("A",1)="Do you need to RE-CREATE the"
.S DIR("A")="DHR for this ADVICE OF ALLOWANCE"
.S DIR("B")="NO"
.W !
.D DIR^ACRFDIC
.Q:$G(Y)'=1
.W !!,"Please note - this will delete the existing DHR and create"
.W !,"a new DHR for this Advice of Allowance. Are you certain"
.W !,"you wish to proceed."
.S DIR(0)="YO"
.S DIR("A")="RE-CREATE the DHR"
.S DIR("B")="NO"
.W !
.D DIR^ACRFDIC
.Q:$G(Y)'=1
.S DA=$P(^ACRALC(ACRZDA,0),U,19)
.S DIK="^ACRALC("
.D DIK^ACRFDIC
.D D1
S DIR(0)="YO"
S DIR("A")="Create DHR for this ADVICE OF ALLOWANCE"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:$G(Y)'=1
I '$P(^ACRALC(ACRZDA,"DT"),U,9) D Q
.W !!,"No CAN has been specified for this allowance."
.W !,"The CAN is required in order to create the DHR."
.W !!,"Please enter the CAN before proceeding."
.D PAUSE^ACRFWARN
N ACRFEDC
S ACRFEDC=2
W !!,"A Document History Record (DHR) will now be created and forwarded"
W !,"to the Health Accounting System."
S DIR(0)="YO"
S DIR("A")="Are you certain you want to proceed"
S DIR("B")="NO"
W !
D DIR^ACRFDIC
Q:$G(Y)'=1
D D1
Q
D1 ;CREATE DHR
K ACROBJ
N ACROBJDA,ACRCANDA
D ANUM
Q:$D(ACRQUIT)
Q:$L($G(ACRANUM))'=10
S ACROBJ((ACRAPP_" "_$E(ACRFY,4)),ACRCANDA,ACROBJDA)=+^ACRALC(ACRZDA,0)
S ACRREF=218
S ACRTCODE=281
S ACRRCODE=$S(+^ACRALC(ACRZDA,0)<0!($G(ACRORIG)="D"):2,1:1)
S ACRMCODE=9
S ACRDOC0=ACRANUM_U_ACRANUM
S (ACRREF,ACRREFX)="043"
D DHR^ACRFDHR
Q:'$G(ACRDA)
S DA=ACRZDA
S DIE="^ACRALC("
S DR=".19////"_ACRDA
D DIE^ACRFDIC
DHRP ;EP;TO PRINT ALLOWANCE DHR
Q:'$G(ACRDA)
N ACRDOCDA
S D0=ACRDA
S (ACRRTN,ZTRTN)="P1^ACRFDHR"
S ZTDESC="PRINT ALLOWANCE DHR"
D ^ACRFZIS
Q
ANUM ;CREATE ADVICE OF ALLOWANCE NUMBER
N ACRFY,ACRFYY,X,Y,Z,ACRACPDA
S X=^ACRALC(ACRZDA,"DT")
S ACRAPPDA=$P(X,U,4)
S ACRCANDA=$P(X,U,9)
S ACRACPDA=$P(X,U,13)
S ACROBJDA=$O(^AUTTOBJC("C","8116",0))
S ACRAPP=$P($G(^AUTTPRO(+ACRAPPDA,0)),U)
S (ACRFY,X)=$P(X,U)
I ACRFY=""!'ACRACPDA S ACRQUIT="" Q
I '$D(^ACRSYS(1,30,"B",ACRFY)) D I 1
.S DA(1)=1
.S:'$D(^ACRSYS(1,30,0)) ^ACRSYS(1,30,0)="^9002199.231"
.S DIC="^ACRSYS(1,30,"
.S DIC(0)="L"
.D FILE^ACRFDIC
S ACRFYY=$O(^ACRSYS(1,30,"B",ACRFY,0))
I 'ACRFYY S ACRQUIT="" Q
I '$D(^ACRSYS(1,30,ACRFYY,1,ACRACPDA)) D
.S (X,DINUM)=ACRACPDA
.S DA(1)=1
.S DA(2)=ACRFYY
.S:'$D(^ACRSYS(1,30,ACRFYY,1,0)) ^ACRSYS(1,30,ACRFYY,1,0)="^9002199.2311"
.S DIC="^ACRSYS(1,30,"_ACRFYY_",1,"
.S DIC(0)="L"
.D FILE^ACRFDIC
ANUM1 L ^ACRSYS(1,30,ACRFYY):2
I $T D I 1
.S X=$P(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)
.S X=X+1
.S $P(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)=X
.L -^ACRSYS(1,30,ACRFYY):0
.S ACRANUM=X
E S ACRQUIT="" Q
S ACRANUM=$E("00000",1,5-$L(ACRANUM))_ACRANUM
S ACRACPT=$P(^AUTTACPT(ACRACPDA,0),U)
S ACRANUM=$E(ACRFY,4)_"AL"_ACRACPT_ACRANUM
I $D(^ACRALC("D",ACRANUM)) G ANUM1
Q
OBLSTAT ;CHECK OBLIGATION STATUS
K ACRQUIT
N ACRX
S ACRX=0
F S ACRX=$O(^ACRDHR("E",ACRDOCDA,ACRX)) Q:'ACRX D
.I $P($G(^ACRDHR(ACRX,1)),U,3,4)="050^1" W !!,"The obligation of funds for this document has been sent to HAS." S ACRQUIT=""
.I $P($G(^ACRDHR(ACRX,1)),U,3,4)="050^2" W !,"But it appears that a de-obligation of funds has also been made." K ACRQUIT
I $D(ACRQUIT) D
.W !!,"This document must be CANCELLED before it can be re-sent to initiator."
.D PAUSE^ACRFWARN
.S ACRQUIT=""
Q
ACRFEA4 ;IHS/OIRM/DSD/THL,AEF - EDIT FINANCIAL DATA; [ 11/01/2001 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFEA
CURRENT ;EP;TO CONTROL EDITING OF ACCOUNT DATA AND REQUESTS
+1 IF '$DATA(ACRFDNO)
IF '$DATA(ACRDOCDA)
SET ACRQUIT=""
QUIT
+2 SET ACRCANDA=$GET(ACRCANDA)
+3 SET ACRLBOC=$GET(ACRLBOC)
+4 ;IF ACRENTRY CONTAINS 'OBL' DATA BEING EDITED IS ALWAYS FOR SPECIFIC
+5 ;FINANCIAL DOCUMENT
+6 KILL ACROUT
+7 IF ACRENTRY["OBL"
IF '$DATA(ACRNEWOB)
IF '$DATA(ACRREV)
IF "^116^204^130^600^148^"[(U_ACRREF_U)!$DATA(ACRPO)
IF '$DATA(ACRREACT)
Begin DoDot:1
+8 DO EDIT^ACRFEA41
+9 IF "^130^600^"[(U_ACRREF_U)
DO RECEIPTS^ACRFSS4
DO TAXI^ACRFSS4
End DoDot:1
QUIT
+10 IF ACRENTRY["OBL"
IF $DATA(ACRDOCDA)
Begin DoDot:1
+11 IF $DATA(^ACRAPVS("AB",ACRDOCDA))
DO ^ACRFDISA
+12 IF $DATA(ACRREACT)
DO REACT
QUIT
+13 IF $PIECE(ACRDOC0,U,4)'=35
FOR
DO ACRDIE^ACRFEA2
IF $DATA(ACRQUIT)!$DATA(ACROUT)!$DATA(ACRREV)!$DATA(ACROUT)
QUIT
+14 IF $DATA(ACROUT)
QUIT
+15 IF ACRREF=130
DO 14^ACRFEA41
+16 KILL ACRQUIT
End DoDot:1
IF '$DATA(ACRNEWOB)
IF $DATA(ACRREACT)
QUIT
+17 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+18 IF $DATA(ACRNEWOB)!$DATA(ACRNEW)
IF $GET(ACRREF)'=148
DO EDIE1^ACRFEA2
KILL ACRNEW
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+19 IF $DATA(ACRNEWOB)
Begin DoDot:1
+20 IF '$DATA(ACRREFX)
SET ACRREFX=ACRREF
+21 IF ACRREFX=116
DO EN^ACRFEA43
End DoDot:1
+22 IF ACRENTRY["OBL"
IF $DATA(ACRDOCDA)
IF '$DATA(ACRREV)
IF '$DATA(ACRPO)
IF $PIECE(ACRDOC0,U,4)'=35
Begin DoDot:1
+23 IF ACRREF'=148
Begin DoDot:2
+24 DO SCREEN^ACRFAU
+25 IF $DATA(ACRSCREN)
KILL ACRSCREN
QUIT
+26 DO DISP^ACRFEA42
End DoDot:2
+27 NEW ACRI
+28 IF ACRREF=148
Begin DoDot:2
+29 DO COURSE^ACRFSS3
+30 DO REMARKS^ACRFEA43
End DoDot:2
QUIT
+31 DO EDIE^ACRFEA2
End DoDot:1
+32 IF ACRENTRY["OBL"
IF $DATA(ACRDOCDA)
IF '$DATA(ACROUT)
Begin DoDot:1
+33 DO ^ACRFSS
+34 IF $DATA(^ACRSS("C",ACRDOCDA))
Begin DoDot:2
+35 IF '$DATA(ACRREV)
IF $GET(ACRREF)'=130
IF $GET(ACRREF)'=148
IF $PIECE(ACRDOC0,U,4)'=35
DO ATTACH^ACRFEA42
+36 IF '$DATA(ACRREV)
IF '$DATA(ACRPO)
IF $DATA(^ACRDOC(ACRDOCDA,"PO"))
IF '$PIECE(^ACRDOC(ACRDOCDA,"PO"),U,5)
DO RV^ACRFEA42
End DoDot:2
End DoDot:1
+37 ;IF ACRENTRY DOES NOT CONTAIN 'OBLA' EDITING IS ALWAYS FOR A FINANCIAL
+38 ;ACCOUNT
+39 IF ACRENTRY'["OBLA"
IF '$DATA(ACRPO)
IF '$DATA(ACRSS6)
Begin DoDot:1
+40 SET DA=ACRZDA
+41 SET DIE=ACRDIE
+42 SET DR=ACRDR
+43 DO DDS^ACRFDIC
+44 IF '$DATA(ACRSCREN)
IF ACRENTRY'["APP"
Begin DoDot:2
+45 SET DR=$PIECE(DR,"INFO]")_"PURPOSE]"
+46 DO DDS^ACRFDIC
End DoDot:2
+47 IF $DATA(ACRSCREN)
KILL ACRSCREN
Begin DoDot:2
+48 DO DISP^ACRFEA42
+49 WRITE !
+50 NEW ACRI
+51 DO EDIE^ACRFEA2
End DoDot:2
+52 IF ACRENTRY["LOCB"
Begin DoDot:2
+53 SET DIR("A")=" Edit ACCOUNT ACCESS? "
+54 SET ACRDR="[ACR DEPARTMENT ACCT ACCESS]"
+55 NEW ACRI
+56 KILL ACRQUIT
+57 SET DA=ACRZDA
+58 SET DIE=ACRDIE
+59 SET DR=ACRDR
+60 DO DDS^ACRFDIC
+61 IF $DATA(ACRSCREN)
KILL ACRSCREN
DO EDIE^ACRFEA2
+62 DO ^ACRFLBTX
End DoDot:2
+63 IF ACRDIC["ACRALC"
DO DHR
End DoDot:1
SET ACRQUIT=""
QUIT
+64 IF $DATA(ACROUT)
QUIT
+65 IF ACRENTRY["OBL"
IF '$DATA(ACRPO)
IF '$DATA(ACRSS6)
IF '$DATA(ACRPRT)
DO ASUM^ACRFEA42
+66 IF $DATA(ACRREV)
Begin DoDot:1
+67 SET D0=ACRDOCDA
+68 DO ^ACRFPAPV
End DoDot:1
+69 IF $DATA(ACRREV)
QUIT
+70 DO SETDOC^ACRFEA1
+71 DO ^ACRFEA41
+72 KILL ACRQUIT
+73 QUIT
REACT ;EP;
+1 DO OBLSTAT
+2 IF $DATA(ACRQUIT)
QUIT
+3 SET DIR("A")="Return Document "_$PIECE(ACRDOC0,U)_" to initiator ? "
+4 WRITE !
+5 DO OUT^ACRFEA2
+6 IF $DATA(ACROUT)!$DATA(ACRQUIT)
QUIT
+7 IF ACRY'=1
QUIT
+8 SET ACRTXDA=$PIECE(ACRDOC0,U,4)
+9 SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+10 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+11 SET ACRREF=$SELECT("^116^204^103^349^326^210^"[(U_ACRREF_U):116,ACRREF=130:130,ACRREF=600:600,ACRREF=148:148,1:116)
+12 IF ACRREF=600
Begin DoDot:1
+13 SET DIR("0")="SO^1:Reprocess TRAVEL ORDER;2:Reprocess TRAVEL VOUCHER"
+14 SET DIR("A")="Which one"
+15 SET DIR("B")="Reprocess TRAVEL ORDER"
+16 WRITE !
+17 DO DIR^ACRFDIC
+18 IF ACRY=1
SET ACRREF=130
End DoDot:1
IF $DATA(ACRQUIT)
QUIT
+19 IF ACRREF=600
SET ACRTXDA=19
+20 SET DA=ACRDOCDA
+21 SET DIE="^ACROBL("
+22 SET DR=$SELECT(ACRREF'=600:"903///@;905///@;906///@;910///@",1:"903////A;905////A;906////Y")_";.1///"_ACRREF_";911///@;907////"_ACRTXDA
+23 DO DIE^ACRFDIC
+24 IF ACRREF'=600
DO KILL^ACRFAPVS
+25 SET DA=ACRDOCDA
+26 SET DIE="^ACRDOC("
+27 SET DR=".13///"_ACRREF_";.14////"_$PIECE($PIECE(^ACRDOC(ACRDOCDA,0),U,14),"CANCELLED ",2)_";.2///@;.3///@;.4///@"
+28 DO DIE^ACRFDIC
+29 SET ACRREFDA=$PIECE(^ACRDOC(ACRDOCDA,0),U,13)
+30 DO KILL^ACRFAPVS
+31 SET ACRY=1
+32 QUIT
RESP ;EP;CHECK TO SEE IF RESPONSE TO APPROVAL RETURN IS REQUIRED
+1 SET ACRRESP=$GET(^ACRDOC(ACRDOCDA,"DT"))
+2 IF +ACRRESP'=1!($PIECE(ACRRESP,U,2)=1)!('$PIECE(ACRRESP,U,10))
KILL ACRRESP
QUIT
+3 SET ACREND=ACREND+1
+4 WRITE *7,*7
+5 WRITE !?5,"*** "
+6 WRITE ?10,ACREND
+7 WRITE ?15,@ACRON,"Response REQUIRED to Approval Inquiry"
+8 WRITE ?45,@ACROF," ***"
+9 QUIT
FEDSET ;EP;
+1 DO DOC1^ACRFFS
+2 SET DA=ACRDOCDA
+3 SET DIE="^ACRDOC("
+4 SET DR="14///GSA;15///A0A;16////"_ACRFLDA_";17////"_ACRFINDA_";18////B"
+5 DO DIE^ACRFDIC
+6 QUIT
DHR ;EP;DETERMINE IF ALLOWANCE DHR SHOULD BE CREATED
+1 IF $PIECE($GET(^ACRSYS(1,"DT1")),U,6)'=1
QUIT
+2 IF '+$GET(^ACRALC(ACRZDA,0))
Begin DoDot:1
+3 WRITE !!,"This account has no dollar value to report to HAS."
+4 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+5 IF $PIECE($GET(^ACRALC(ACRZDA,0)),U,19)
SET ACRDHRDA=$PIECE(^(0),U,19)
Begin DoDot:1
+6 WRITE !,"DHR ",@ACRON,$PIECE($GET(^ACRDHR(ACRDHRDA,0)),U),@ACROF," has been created for this advice of allowance."
+7 NEW DXS,DIP
+8 SET D0=ACRDHRDA
+9 DO ^ACRDHR
+10 DO PAUSE^ACRFWARN
+11 IF $DATA(ACRQUIT)
QUIT
+12 SET DIR(0)="YO"
+13 SET DIR("A",1)="Do you need to RE-CREATE the"
+14 SET DIR("A")="DHR for this ADVICE OF ALLOWANCE"
+15 SET DIR("B")="NO"
+16 WRITE !
+17 DO DIR^ACRFDIC
+18 IF $GET(Y)'=1
QUIT
+19 WRITE !!,"Please note - this will delete the existing DHR and create"
+20 WRITE !,"a new DHR for this Advice of Allowance. Are you certain"
+21 WRITE !,"you wish to proceed."
+22 SET DIR(0)="YO"
+23 SET DIR("A")="RE-CREATE the DHR"
+24 SET DIR("B")="NO"
+25 WRITE !
+26 DO DIR^ACRFDIC
+27 IF $GET(Y)'=1
QUIT
+28 SET DA=$PIECE(^ACRALC(ACRZDA,0),U,19)
+29 SET DIK="^ACRALC("
+30 DO DIK^ACRFDIC
+31 DO D1
End DoDot:1
QUIT
+32 SET DIR(0)="YO"
+33 SET DIR("A")="Create DHR for this ADVICE OF ALLOWANCE"
+34 SET DIR("B")="NO"
+35 WRITE !
+36 DO DIR^ACRFDIC
+37 IF $GET(Y)'=1
QUIT
+38 IF '$PIECE(^ACRALC(ACRZDA,"DT"),U,9)
Begin DoDot:1
+39 WRITE !!,"No CAN has been specified for this allowance."
+40 WRITE !,"The CAN is required in order to create the DHR."
+41 WRITE !!,"Please enter the CAN before proceeding."
+42 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+43 NEW ACRFEDC
+44 SET ACRFEDC=2
+45 WRITE !!,"A Document History Record (DHR) will now be created and forwarded"
+46 WRITE !,"to the Health Accounting System."
+47 SET DIR(0)="YO"
+48 SET DIR("A")="Are you certain you want to proceed"
+49 SET DIR("B")="NO"
+50 WRITE !
+51 DO DIR^ACRFDIC
+52 IF $GET(Y)'=1
QUIT
+53 DO D1
+54 QUIT
D1 ;CREATE DHR
+1 KILL ACROBJ
+2 NEW ACROBJDA,ACRCANDA
+3 DO ANUM
+4 IF $DATA(ACRQUIT)
QUIT
+5 IF $LENGTH($GET(ACRANUM))'=10
QUIT
+6 SET ACROBJ((ACRAPP_" "_$EXTRACT(ACRFY,4)),ACRCANDA,ACROBJDA)=+^ACRALC(ACRZDA,0)
+7 SET ACRREF=218
+8 SET ACRTCODE=281
+9 SET ACRRCODE=$SELECT(+^ACRALC(ACRZDA,0)<0!($GET(ACRORIG)="D"):2,1:1)
+10 SET ACRMCODE=9
+11 SET ACRDOC0=ACRANUM_U_ACRANUM
+12 SET (ACRREF,ACRREFX)="043"
+13 DO DHR^ACRFDHR
+14 IF '$GET(ACRDA)
QUIT
+15 SET DA=ACRZDA
+16 SET DIE="^ACRALC("
+17 SET DR=".19////"_ACRDA
+18 DO DIE^ACRFDIC
DHRP ;EP;TO PRINT ALLOWANCE DHR
+1 IF '$GET(ACRDA)
QUIT
+2 NEW ACRDOCDA
+3 SET D0=ACRDA
+4 SET (ACRRTN,ZTRTN)="P1^ACRFDHR"
+5 SET ZTDESC="PRINT ALLOWANCE DHR"
+6 DO ^ACRFZIS
+7 QUIT
ANUM ;CREATE ADVICE OF ALLOWANCE NUMBER
+1 NEW ACRFY,ACRFYY,X,Y,Z,ACRACPDA
+2 SET X=^ACRALC(ACRZDA,"DT")
+3 SET ACRAPPDA=$PIECE(X,U,4)
+4 SET ACRCANDA=$PIECE(X,U,9)
+5 SET ACRACPDA=$PIECE(X,U,13)
+6 SET ACROBJDA=$ORDER(^AUTTOBJC("C","8116",0))
+7 SET ACRAPP=$PIECE($GET(^AUTTPRO(+ACRAPPDA,0)),U)
+8 SET (ACRFY,X)=$PIECE(X,U)
+9 IF ACRFY=""!'ACRACPDA
SET ACRQUIT=""
QUIT
+10 IF '$DATA(^ACRSYS(1,30,"B",ACRFY))
Begin DoDot:1
+11 SET DA(1)=1
+12 IF '$DATA(^ACRSYS(1,30,0))
SET ^ACRSYS(1,30,0)="^9002199.231"
+13 SET DIC="^ACRSYS(1,30,"
+14 SET DIC(0)="L"
+15 DO FILE^ACRFDIC
End DoDot:1
IF 1
+16 SET ACRFYY=$ORDER(^ACRSYS(1,30,"B",ACRFY,0))
+17 IF 'ACRFYY
SET ACRQUIT=""
QUIT
+18 IF '$DATA(^ACRSYS(1,30,ACRFYY,1,ACRACPDA))
Begin DoDot:1
+19 SET (X,DINUM)=ACRACPDA
+20 SET DA(1)=1
+21 SET DA(2)=ACRFYY
+22 IF '$DATA(^ACRSYS(1,30,ACRFYY,1,0))
SET ^ACRSYS(1,30,ACRFYY,1,0)="^9002199.2311"
+23 SET DIC="^ACRSYS(1,30,"_ACRFYY_",1,"
+24 SET DIC(0)="L"
+25 DO FILE^ACRFDIC
End DoDot:1
ANUM1 LOCK ^ACRSYS(1,30,ACRFYY):2
+1 IF $TEST
Begin DoDot:1
+2 SET X=$PIECE(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)
+3 SET X=X+1
+4 SET $PIECE(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)=X
+5 LOCK -^ACRSYS(1,30,ACRFYY):0
+6 SET ACRANUM=X
End DoDot:1
IF 1
+7 IF '$TEST
SET ACRQUIT=""
QUIT
+8 SET ACRANUM=$EXTRACT("00000",1,5-$LENGTH(ACRANUM))_ACRANUM
+9 SET ACRACPT=$PIECE(^AUTTACPT(ACRACPDA,0),U)
+10 SET ACRANUM=$EXTRACT(ACRFY,4)_"AL"_ACRACPT_ACRANUM
+11 IF $DATA(^ACRALC("D",ACRANUM))
GOTO ANUM1
+12 QUIT
OBLSTAT ;CHECK OBLIGATION STATUS
+1 KILL ACRQUIT
+2 NEW ACRX
+3 SET ACRX=0
+4 FOR
SET ACRX=$ORDER(^ACRDHR("E",ACRDOCDA,ACRX))
IF 'ACRX
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^ACRDHR(ACRX,1)),U,3,4)="050^1"
WRITE !!,"The obligation of funds for this document has been sent to HAS."
SET ACRQUIT=""
+6 IF $PIECE($GET(^ACRDHR(ACRX,1)),U,3,4)="050^2"
WRITE !,"But it appears that a de-obligation of funds has also been made."
KILL ACRQUIT
End DoDot:1
+7 IF $DATA(ACRQUIT)
Begin DoDot:1
+8 WRITE !!,"This document must be CANCELLED before it can be re-sent to initiator."
+9 DO PAUSE^ACRFWARN
+10 SET ACRQUIT=""
End DoDot:1
+11 QUIT
