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

ACRFEA4.m

Go to the documentation of this file.
  1. 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
  1. ;;CONTINUATION OF ACRFEA
  1. CURRENT ;EP;TO CONTROL EDITING OF ACCOUNT DATA AND REQUESTS
  1. I '$D(ACRFDNO),'$D(ACRDOCDA) S ACRQUIT="" Q
  1. S ACRCANDA=$G(ACRCANDA)
  1. S ACRLBOC=$G(ACRLBOC)
  1. ;IF ACRENTRY CONTAINS 'OBL' DATA BEING EDITED IS ALWAYS FOR SPECIFIC
  1. ;FINANCIAL DOCUMENT
  1. K ACROUT
  1. I ACRENTRY["OBL",'$D(ACRNEWOB),'$D(ACRREV),"^116^204^130^600^148^"[(U_ACRREF_U)!$D(ACRPO),'$D(ACRREACT) D Q
  1. .D EDIT^ACRFEA41
  1. .I "^130^600^"[(U_ACRREF_U) D RECEIPTS^ACRFSS4,TAXI^ACRFSS4
  1. I ACRENTRY["OBL",$D(ACRDOCDA) D I '$D(ACRNEWOB) Q:$D(ACRREACT)
  1. .I $D(^ACRAPVS("AB",ACRDOCDA)) D ^ACRFDISA
  1. .I $D(ACRREACT) D REACT Q
  1. .I $P(ACRDOC0,U,4)'=35 F D ACRDIE^ACRFEA2 Q:$D(ACRQUIT)!$D(ACROUT)!$D(ACRREV)!$D(ACROUT)
  1. .Q:$D(ACROUT)
  1. .I ACRREF=130 D 14^ACRFEA41
  1. .K ACRQUIT
  1. Q:$D(ACRQUIT)!$D(ACROUT)
  1. I $D(ACRNEWOB)!$D(ACRNEW),$G(ACRREF)'=148 D EDIE1^ACRFEA2 K ACRNEW Q:$D(ACRQUIT)!$D(ACROUT)
  1. I $D(ACRNEWOB) D
  1. .S:'$D(ACRREFX) ACRREFX=ACRREF
  1. .D:ACRREFX=116 EN^ACRFEA43
  1. I ACRENTRY["OBL",$D(ACRDOCDA),'$D(ACRREV),'$D(ACRPO),$P(ACRDOC0,U,4)'=35 D
  1. .I ACRREF'=148 D
  1. ..D SCREEN^ACRFAU
  1. ..I $D(ACRSCREN) K ACRSCREN Q
  1. ..D DISP^ACRFEA42
  1. .N ACRI
  1. .I ACRREF=148 D Q
  1. ..D COURSE^ACRFSS3
  1. ..D REMARKS^ACRFEA43
  1. .D EDIE^ACRFEA2
  1. I ACRENTRY["OBL",$D(ACRDOCDA),'$D(ACROUT) D
  1. .D ^ACRFSS
  1. .I $D(^ACRSS("C",ACRDOCDA)) D
  1. ..I '$D(ACRREV),$G(ACRREF)'=130,$G(ACRREF)'=148,$P(ACRDOC0,U,4)'=35 D ATTACH^ACRFEA42
  1. ..I '$D(ACRREV),'$D(ACRPO),$D(^ACRDOC(ACRDOCDA,"PO")),'$P(^ACRDOC(ACRDOCDA,"PO"),U,5) D RV^ACRFEA42
  1. ;IF ACRENTRY DOES NOT CONTAIN 'OBLA' EDITING IS ALWAYS FOR A FINANCIAL
  1. ;ACCOUNT
  1. I ACRENTRY'["OBLA",'$D(ACRPO),'$D(ACRSS6) D S ACRQUIT="" Q
  1. .S DA=ACRZDA
  1. .S DIE=ACRDIE
  1. .S DR=ACRDR
  1. .D DDS^ACRFDIC
  1. .I '$D(ACRSCREN),ACRENTRY'["APP" D
  1. ..S DR=$P(DR,"INFO]")_"PURPOSE]"
  1. ..D DDS^ACRFDIC
  1. .I $D(ACRSCREN) K ACRSCREN D
  1. ..D DISP^ACRFEA42
  1. ..W !
  1. ..N ACRI
  1. ..D EDIE^ACRFEA2
  1. .I ACRENTRY["LOCB" D
  1. ..S DIR("A")=" Edit ACCOUNT ACCESS? "
  1. ..S ACRDR="[ACR DEPARTMENT ACCT ACCESS]"
  1. ..N ACRI
  1. ..K ACRQUIT
  1. ..S DA=ACRZDA
  1. ..S DIE=ACRDIE
  1. ..S DR=ACRDR
  1. ..D DDS^ACRFDIC
  1. ..I $D(ACRSCREN) K ACRSCREN D EDIE^ACRFEA2
  1. ..D ^ACRFLBTX
  1. .D DHR:ACRDIC["ACRALC"
  1. Q:$D(ACROUT)
  1. I ACRENTRY["OBL",'$D(ACRPO),'$D(ACRSS6),'$D(ACRPRT) D ASUM^ACRFEA42
  1. I $D(ACRREV) D
  1. .S D0=ACRDOCDA
  1. .D ^ACRFPAPV
  1. Q:$D(ACRREV)
  1. D SETDOC^ACRFEA1
  1. D ^ACRFEA41
  1. K ACRQUIT
  1. Q
  1. REACT ;EP;
  1. D OBLSTAT
  1. Q:$D(ACRQUIT)
  1. S DIR("A")="Return Document "_$P(ACRDOC0,U)_" to initiator ? "
  1. W !
  1. D OUT^ACRFEA2
  1. Q:$D(ACROUT)!$D(ACRQUIT)
  1. Q:ACRY'=1
  1. S ACRTXDA=$P(ACRDOC0,U,4)
  1. S ACRREFDA=$P(ACRDOC0,U,13)
  1. S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
  1. S ACRREF=$S("^116^204^103^349^326^210^"[(U_ACRREF_U):116,ACRREF=130:130,ACRREF=600:600,ACRREF=148:148,1:116)
  1. I ACRREF=600 D Q:$D(ACRQUIT)
  1. .S DIR("0")="SO^1:Reprocess TRAVEL ORDER;2:Reprocess TRAVEL VOUCHER"
  1. .S DIR("A")="Which one"
  1. .S DIR("B")="Reprocess TRAVEL ORDER"
  1. .W !
  1. .D DIR^ACRFDIC
  1. .S:ACRY=1 ACRREF=130
  1. S:ACRREF=600 ACRTXDA=19
  1. S DA=ACRDOCDA
  1. S DIE="^ACROBL("
  1. S DR=$S(ACRREF'=600:"903///@;905///@;906///@;910///@",1:"903////A;905////A;906////Y")_";.1///"_ACRREF_";911///@;907////"_ACRTXDA
  1. D DIE^ACRFDIC
  1. D:ACRREF'=600 KILL^ACRFAPVS
  1. S DA=ACRDOCDA
  1. S DIE="^ACRDOC("
  1. S DR=".13///"_ACRREF_";.14////"_$P($P(^ACRDOC(ACRDOCDA,0),U,14),"CANCELLED ",2)_";.2///@;.3///@;.4///@"
  1. D DIE^ACRFDIC
  1. S ACRREFDA=$P(^ACRDOC(ACRDOCDA,0),U,13)
  1. D KILL^ACRFAPVS
  1. S ACRY=1
  1. Q
  1. RESP ;EP;CHECK TO SEE IF RESPONSE TO APPROVAL RETURN IS REQUIRED
  1. S ACRRESP=$G(^ACRDOC(ACRDOCDA,"DT"))
  1. I +ACRRESP'=1!($P(ACRRESP,U,2)=1)!('$P(ACRRESP,U,10)) K ACRRESP Q
  1. S ACREND=ACREND+1
  1. W *7,*7
  1. W !?5,"*** "
  1. W ?10,ACREND
  1. W ?15,@ACRON,"Response REQUIRED to Approval Inquiry"
  1. W ?45,@ACROF," ***"
  1. Q
  1. FEDSET ;EP;
  1. D DOC1^ACRFFS
  1. S DA=ACRDOCDA
  1. S DIE="^ACRDOC("
  1. S DR="14///GSA;15///A0A;16////"_ACRFLDA_";17////"_ACRFINDA_";18////B"
  1. D DIE^ACRFDIC
  1. Q
  1. DHR ;EP;DETERMINE IF ALLOWANCE DHR SHOULD BE CREATED
  1. Q:$P($G(^ACRSYS(1,"DT1")),U,6)'=1
  1. I '+$G(^ACRALC(ACRZDA,0)) D Q
  1. .W !!,"This account has no dollar value to report to HAS."
  1. .D PAUSE^ACRFWARN
  1. I $P($G(^ACRALC(ACRZDA,0)),U,19) S ACRDHRDA=$P(^(0),U,19) D Q
  1. .W !,"DHR ",@ACRON,$P($G(^ACRDHR(ACRDHRDA,0)),U),@ACROF," has been created for this advice of allowance."
  1. .N DXS,DIP
  1. .S D0=ACRDHRDA
  1. .D ^ACRDHR
  1. .D PAUSE^ACRFWARN
  1. .Q:$D(ACRQUIT)
  1. .S DIR(0)="YO"
  1. .S DIR("A",1)="Do you need to RE-CREATE the"
  1. .S DIR("A")="DHR for this ADVICE OF ALLOWANCE"
  1. .S DIR("B")="NO"
  1. .W !
  1. .D DIR^ACRFDIC
  1. .Q:$G(Y)'=1
  1. .W !!,"Please note - this will delete the existing DHR and create"
  1. .W !,"a new DHR for this Advice of Allowance. Are you certain"
  1. .W !,"you wish to proceed."
  1. .S DIR(0)="YO"
  1. .S DIR("A")="RE-CREATE the DHR"
  1. .S DIR("B")="NO"
  1. .W !
  1. .D DIR^ACRFDIC
  1. .Q:$G(Y)'=1
  1. .S DA=$P(^ACRALC(ACRZDA,0),U,19)
  1. .S DIK="^ACRALC("
  1. .D DIK^ACRFDIC
  1. .D D1
  1. S DIR(0)="YO"
  1. S DIR("A")="Create DHR for this ADVICE OF ALLOWANCE"
  1. S DIR("B")="NO"
  1. W !
  1. D DIR^ACRFDIC
  1. Q:$G(Y)'=1
  1. I '$P(^ACRALC(ACRZDA,"DT"),U,9) D Q
  1. .W !!,"No CAN has been specified for this allowance."
  1. .W !,"The CAN is required in order to create the DHR."
  1. .W !!,"Please enter the CAN before proceeding."
  1. .D PAUSE^ACRFWARN
  1. N ACRFEDC
  1. S ACRFEDC=2
  1. W !!,"A Document History Record (DHR) will now be created and forwarded"
  1. W !,"to the Health Accounting System."
  1. S DIR(0)="YO"
  1. S DIR("A")="Are you certain you want to proceed"
  1. S DIR("B")="NO"
  1. W !
  1. D DIR^ACRFDIC
  1. Q:$G(Y)'=1
  1. D D1
  1. Q
  1. D1 ;CREATE DHR
  1. K ACROBJ
  1. N ACROBJDA,ACRCANDA
  1. D ANUM
  1. Q:$D(ACRQUIT)
  1. Q:$L($G(ACRANUM))'=10
  1. S ACROBJ((ACRAPP_" "_$E(ACRFY,4)),ACRCANDA,ACROBJDA)=+^ACRALC(ACRZDA,0)
  1. S ACRREF=218
  1. S ACRTCODE=281
  1. S ACRRCODE=$S(+^ACRALC(ACRZDA,0)<0!($G(ACRORIG)="D"):2,1:1)
  1. S ACRMCODE=9
  1. S ACRDOC0=ACRANUM_U_ACRANUM
  1. S (ACRREF,ACRREFX)="043"
  1. D DHR^ACRFDHR
  1. Q:'$G(ACRDA)
  1. S DA=ACRZDA
  1. S DIE="^ACRALC("
  1. S DR=".19////"_ACRDA
  1. D DIE^ACRFDIC
  1. DHRP ;EP;TO PRINT ALLOWANCE DHR
  1. Q:'$G(ACRDA)
  1. N ACRDOCDA
  1. S D0=ACRDA
  1. S (ACRRTN,ZTRTN)="P1^ACRFDHR"
  1. S ZTDESC="PRINT ALLOWANCE DHR"
  1. D ^ACRFZIS
  1. Q
  1. ANUM ;CREATE ADVICE OF ALLOWANCE NUMBER
  1. N ACRFY,ACRFYY,X,Y,Z,ACRACPDA
  1. S X=^ACRALC(ACRZDA,"DT")
  1. S ACRAPPDA=$P(X,U,4)
  1. S ACRCANDA=$P(X,U,9)
  1. S ACRACPDA=$P(X,U,13)
  1. S ACROBJDA=$O(^AUTTOBJC("C","8116",0))
  1. S ACRAPP=$P($G(^AUTTPRO(+ACRAPPDA,0)),U)
  1. S (ACRFY,X)=$P(X,U)
  1. I ACRFY=""!'ACRACPDA S ACRQUIT="" Q
  1. I '$D(^ACRSYS(1,30,"B",ACRFY)) D I 1
  1. .S DA(1)=1
  1. .S:'$D(^ACRSYS(1,30,0)) ^ACRSYS(1,30,0)="^9002199.231"
  1. .S DIC="^ACRSYS(1,30,"
  1. .S DIC(0)="L"
  1. .D FILE^ACRFDIC
  1. S ACRFYY=$O(^ACRSYS(1,30,"B",ACRFY,0))
  1. I 'ACRFYY S ACRQUIT="" Q
  1. I '$D(^ACRSYS(1,30,ACRFYY,1,ACRACPDA)) D
  1. .S (X,DINUM)=ACRACPDA
  1. .S DA(1)=1
  1. .S DA(2)=ACRFYY
  1. .S:'$D(^ACRSYS(1,30,ACRFYY,1,0)) ^ACRSYS(1,30,ACRFYY,1,0)="^9002199.2311"
  1. .S DIC="^ACRSYS(1,30,"_ACRFYY_",1,"
  1. .S DIC(0)="L"
  1. .D FILE^ACRFDIC
  1. ANUM1 L ^ACRSYS(1,30,ACRFYY):2
  1. I $T D I 1
  1. .S X=$P(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)
  1. .S X=X+1
  1. .S $P(^ACRSYS(1,30,ACRFYY,1,ACRACPDA,0),U,2)=X
  1. .L -^ACRSYS(1,30,ACRFYY):0
  1. .S ACRANUM=X
  1. E S ACRQUIT="" Q
  1. S ACRANUM=$E("00000",1,5-$L(ACRANUM))_ACRANUM
  1. S ACRACPT=$P(^AUTTACPT(ACRACPDA,0),U)
  1. S ACRANUM=$E(ACRFY,4)_"AL"_ACRACPT_ACRANUM
  1. I $D(^ACRALC("D",ACRANUM)) G ANUM1
  1. Q
  1. OBLSTAT ;CHECK OBLIGATION STATUS
  1. K ACRQUIT
  1. N ACRX
  1. S ACRX=0
  1. F S ACRX=$O(^ACRDHR("E",ACRDOCDA,ACRX)) Q:'ACRX D
  1. .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=""
  1. .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
  1. I $D(ACRQUIT) D
  1. .W !!,"This document must be CANCELLED before it can be re-sent to initiator."
  1. .D PAUSE^ACRFWARN
  1. .S ACRQUIT=""
  1. Q