- 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