ACRFEA1 ;IHS/OIRM/DSD/THL,AEF - ACRFEA CON'T; [ 04/25/2007 10:23 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,22**;NOV 05, 2001
;;CONTINUATION OF ACRFEA
DICOBL K ACRH,ACRBPA
I $D(ACRNEWOB) D CANCHK Q:$D(ACRQUIT)!$D(ACROUT) D I $D(ACRTXTP)!$D(ACRQUIT)!$D(ACROUT) S ACRQUIT="" Q
.S $P(ACRDOC0,U,6)=ACRZDA
.D ASUM^ACRFEA42
.S DIR(0)="YO"
.S DIR("A",1)="After reviewing the ACCOUNT SUMMARY above, are you"
.S DIR("A")="certain this is the ACCOUNT you want to use."
.S DIR("B")="YES"
.W !
.D DIR^ACRFDIC
.I +Y'=1 S ACRQUIT="" Q
.D AMEND^ACRFNEWD
.Q:$D(ACRQUIT)
.I $D(ACRAMEND) D A1 S (ACROUT,ACRQUIT)="" Q
.D:'$D(ACRAMEND) ^ACRFTXTP
.I ACRTXDA=31 D CHOOSE^ACRFBPA I $D(ACRQUIT)!'$D(ACRBPA) S ACRQUIT="" Q
.I $D(ACRXACT),ACRTXDA'=32,$P(^ACRSYS(1,0),U,98) D Q:$D(ACRQUIT)!$D(ACROUT)
..K ACRXDOC
..I '$D(^ACROBL("D",ACRFDNO)) D NOTIE Q
..S X=0
..S X=$O(^ACROBL("D",ACRFDNO,0)) I $P(^ACRDOC(X,0),U,4)=32 S ACRXDOC=X Q
..I '$D(ACRXDOC) D NOTIE
S DIC=$S(ACRENTRY'["OBLAMT":ACRDIC,1:"^ACRDOC(")
S DIC(0)=$S($D(ACRNEWOB):"AELQZ",1:"AENQZ")
S DIC("A")=$S($D(ACRNEWOB):ACRDIC("A"),1:"ID NO.: ")
S DIC("DR")=""
S:ACRENTRY["OBLAMT" D="B^C^G^J"
I '$D(ACRNEWOB) D:'$D(ACRQUIT)
.K ACRDOCDA
.D DIC^ACRFDIC:ACRENTRY'["OBLAMT"
.D MIX^ACRFDIC:ACRENTRY["OBLAMT"&'$D(ACRPRT)#2
.I $D(ACRPRT)#2 D ^ACRFPALL Q
.S:U[$E(X)!(X="")!(+Y<1) ACRQUIT=""
.I +Y>0 D
..S (ACRDOCDA,ACRZDA)=+Y
..D SETDOC
..S ACRREFX=ACRREF
..S ACROBL=+ACROBL0
I $D(ACRNEWOB) D Q
.S ACRALWDA=$P(^ACRLOCB(ACRFDNDA,0),U,3)
.S ACRALWNO=$P(^ACRLOCB(ACRFDNDA,"DT"),U,5)
.D BEGIN^ACRFNEWD
.I $D(ACRXACT),ACRTXDA=32 S ACRXDOC=ACRDOCDA
Q:$D(ACRQUIT)!$D(ACROUT)!$D(ACRPRT)
I $D(ACRCSI) D Q
.S D0=ACRDOCDA
.D SETDOC
.S ACRREFX=ACRREF
.D ^ACRFPAPV
I $D(ACRPTX) D ^ACRFTRX Q
S ACRLBDA=$P(ACROBL0,U,3)
S ACRREFDA=$P(ACRDOC0,U,13)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
I $D(ACRDEL) D Q
.S ACRDOC=$S($P(ACRDOC0,U,2)]""&'$D(ACRREQST):$P(ACRDOC0,U,2),1:$P(ACRDOC0,U))
.S ACRID=$P(ACRDOC0,U,14)
.D ^ACRFDEL
.S ACRQUIT=""
Q
SETDOC ;EP;TO SET DOCUMENT VARIABLES
I '$D(^ACRDOC(ACRDOCDA,0))!'$D(^ACRDOC(ACRDOCDA,"DT"))!($E($G(^ACRDOC(ACRDOCDA,0)),1,5)="^^^^^")!'$D(^ACROBL(ACRDOCDA,0)) D Q
.;F DIK="^ACROBL(","^ACRDOC(" S DA=ACRDOCDA D DIK^ACRFDIC ;ACR*2.1*16.14 IM14779
.W !!!,"***** Problems with FMS Document and/or FMS Request files" ;ACR*2.1*16.14 IM14779
.W !,"******* please notify the ARMS Manager immediately!!!!" ;ACR*2.1*16.14 IM14779
.W !,"********* and give them the document ID Number ",ACRDOCDA ;ACR*2.1*22.09 IM24355
.D PAUSE^ACRFWARN ;ACR*2.1*16.14 IM14779
.S ACRQUIT=""
S ACRDOC0=^ACRDOC(ACRDOCDA,0)
S ACRDOCDT=^ACRDOC(ACRDOCDA,"DT")
S ACRDOCPO=$G(^ACRDOC(ACRDOCDA,"PO"))
S ACROBL0=$G(^ACROBL(ACRDOCDA,0))
S ACROBLDT=$G(^ACROBL(ACRDOCDA,"DT"))
S ACROBLAP=$G(^ACROBL(ACRDOCDA,"APV"))
S ACRID=$P(ACRDOC0,U,14)
S ACRREFDA=$P(ACRDOC0,U,13)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
S ACRDOC=$S(ACRREF'=103&(ACRREF'=349)&(ACRREF'=326)&(ACRREF'=210):$P(ACRDOC0,U),1:$P(ACRDOC0,U,2))
S ACRLBDA=$P(ACRDOC0,U,6)
S ACRPODA=$P(ACRDOC0,U,8)
S ACRTXDA=$P(ACRDOC0,U,4)
S ACRACPT=$P($G(^ACRPO(+ACRPODA,0)),U,4)
S ACRACPT=$P($G(^AUTTACPT(+ACRACPT,0)),U)
I 'ACRPODA D
.N DIE,DR,DA
.S ACRPODA=1
.S DA=ACRDOCDA
.S DIE="^ACRDOC("
.S DR=".08////1"
.D DIE^ACRFDIC
S ACRADA=$P(^ACRPO(ACRPODA,0),U,19)
S:'ACRADA ACRADA=1
Q
CANCHK ;EP;TO CHECK FOR REQUIRED CAN DEFAULT DATA
K ACRQUIT
N ACRI,ACR,ACRX
F ACRI=0,"DFLT","DFLT1" I '$D(^ACRCAN(ACRCANDA,ACRI)) S ACR="" D BADMES Q
Q:$D(ACRQUIT)!$D(ACROUT)
F ACRI=1:1:6,8,10:1:22,24,25 I $P($G(^ACRCAN(ACRCANDA,"DFLT")),U,ACRI)="" S ACRX="D"_ACRI D BADCAN
Q:$D(ACRQUIT)!$D(ACROUT)
F ACRI=3,8,10,11,13:1:15,17,20 I $P($G(^ACRCAN(ACRCANDA,"DFLT1")),U,ACRI)="" S ACRX="DD"_ACRI D BADCAN
D BADMES:$D(ACR)
Q
BADCAN S ACRX=$T(@ACRX),ACR($P(ACRX,";;",2))=""
Q
BADMES W *7,*7
W !!,"CAN ",@ACRON,ACRFDNCA,@ACROF," has missing default data."
W !,"Notify your systems administrator immediately."
W !
S ACRX=0
F S ACRX=$O(ACR(ACRX)) Q:'ACRX D
.W !?10,$P(^DD(9002186.5,ACRX,0),U)
D PAUSE^ACRFWARN
;K ACRQUIT ;ACR*2.1*16.02 IM14652
S:$D(ACROUT) ACRQUIT="" ;ACR*2.1*16.02 IM14652
Q
NOTIE W *7,*7
W !!,"No TIE UP document has been created for this account. You must create"
W !,"the TIE UP document before obligating any funds for this account."
D PAUSE^ACRFWARN
S ACRQUIT=""
Q
A1 ;EP;TO PROCESS MODIFICATION
S ACRDOCDA=ACRAMEND
K ACRNOT
D EN1^ACRFAUTO
S (DA,ACRDOCDA)=ACROBL2
S DIE="^ACROBL("
S DR="903///@;905///@;906///@;909///@;912///@;911///@"
D DIE^ACRFDIC
S DA=ACROBL2
S DIE="^ACRDOC("
S DR=".15////"_ACRAMEND
D DIE^ACRFDIC
K ACROBL2
D SETDOC
D ^ACRFEA41
Q
D1 ;;1000
D2 ;;1010
D3 ;;1020
D4 ;;1030
D5 ;;1040
D6 ;;1050
D8 ;;1070
D10 ;;1090
D11 ;;1100
D12 ;;1110
D13 ;;1120
D14 ;;1130
D15 ;;1140
D16 ;;1150
D17 ;;1160
D18 ;;1170
D19 ;;1180
D20 ;;1190
D21 ;;1200
D22 ;;1210
D24 ;;1230
D25 ;;1240
DD3 ;;1250
DD8 ;;1032
DD10 ;;1300
DD11 ;;1310
DD13 ;;1330
DD14 ;;1340
DD15 ;;1350
DD17 ;;1370
DD20 ;;1400
ACRFEA1 ;IHS/OIRM/DSD/THL,AEF - ACRFEA CON'T; [ 04/25/2007 10:23 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**16,22**;NOV 05, 2001
+2 ;;CONTINUATION OF ACRFEA
DICOBL KILL ACRH,ACRBPA
+1 IF $DATA(ACRNEWOB)
DO CANCHK
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
Begin DoDot:1
+2 SET $PIECE(ACRDOC0,U,6)=ACRZDA
+3 DO ASUM^ACRFEA42
+4 SET DIR(0)="YO"
+5 SET DIR("A",1)="After reviewing the ACCOUNT SUMMARY above, are you"
+6 SET DIR("A")="certain this is the ACCOUNT you want to use."
+7 SET DIR("B")="YES"
+8 WRITE !
+9 DO DIR^ACRFDIC
+10 IF +Y'=1
SET ACRQUIT=""
QUIT
+11 DO AMEND^ACRFNEWD
+12 IF $DATA(ACRQUIT)
QUIT
+13 IF $DATA(ACRAMEND)
DO A1
SET (ACROUT,ACRQUIT)=""
QUIT
+14 IF '$DATA(ACRAMEND)
DO ^ACRFTXTP
+15 IF ACRTXDA=31
DO CHOOSE^ACRFBPA
IF $DATA(ACRQUIT)!'$DATA(ACRBPA)
SET ACRQUIT=""
QUIT
+16 IF $DATA(ACRXACT)
IF ACRTXDA'=32
IF $PIECE(^ACRSYS(1,0),U,98)
Begin DoDot:2
+17 KILL ACRXDOC
+18 IF '$DATA(^ACROBL("D",ACRFDNO))
DO NOTIE
QUIT
+19 SET X=0
+20 SET X=$ORDER(^ACROBL("D",ACRFDNO,0))
IF $PIECE(^ACRDOC(X,0),U,4)=32
SET ACRXDOC=X
QUIT
+21 IF '$DATA(ACRXDOC)
DO NOTIE
End DoDot:2
IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
End DoDot:1
IF $DATA(ACRTXTP)!$DATA(ACRQUIT)!$DATA(ACROUT)
SET ACRQUIT=""
QUIT
+22 SET DIC=$SELECT(ACRENTRY'["OBLAMT":ACRDIC,1:"^ACRDOC(")
+23 SET DIC(0)=$SELECT($DATA(ACRNEWOB):"AELQZ",1:"AENQZ")
+24 SET DIC("A")=$SELECT($DATA(ACRNEWOB):ACRDIC("A"),1:"ID NO.: ")
+25 SET DIC("DR")=""
+26 IF ACRENTRY["OBLAMT"
SET D="B^C^G^J"
+27 IF '$DATA(ACRNEWOB)
IF '$DATA(ACRQUIT)
Begin DoDot:1
+28 KILL ACRDOCDA
+29 IF ACRENTRY'["OBLAMT"
DO DIC^ACRFDIC
+30 IF ACRENTRY["OBLAMT"&'$DATA(ACRPRT)#2
DO MIX^ACRFDIC
+31 IF $DATA(ACRPRT)#2
DO ^ACRFPALL
QUIT
+32 IF U[$EXTRACT(X)!(X="")!(+Y<1)
SET ACRQUIT=""
+33 IF +Y>0
Begin DoDot:2
+34 SET (ACRDOCDA,ACRZDA)=+Y
+35 DO SETDOC
+36 SET ACRREFX=ACRREF
+37 SET ACROBL=+ACROBL0
End DoDot:2
End DoDot:1
+38 IF $DATA(ACRNEWOB)
Begin DoDot:1
+39 SET ACRALWDA=$PIECE(^ACRLOCB(ACRFDNDA,0),U,3)
+40 SET ACRALWNO=$PIECE(^ACRLOCB(ACRFDNDA,"DT"),U,5)
+41 DO BEGIN^ACRFNEWD
+42 IF $DATA(ACRXACT)
IF ACRTXDA=32
SET ACRXDOC=ACRDOCDA
End DoDot:1
QUIT
+43 IF $DATA(ACRQUIT)!$DATA(ACROUT)!$DATA(ACRPRT)
QUIT
+44 IF $DATA(ACRCSI)
Begin DoDot:1
+45 SET D0=ACRDOCDA
+46 DO SETDOC
+47 SET ACRREFX=ACRREF
+48 DO ^ACRFPAPV
End DoDot:1
QUIT
+49 IF $DATA(ACRPTX)
DO ^ACRFTRX
QUIT
+50 SET ACRLBDA=$PIECE(ACROBL0,U,3)
+51 SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+52 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+53 IF $DATA(ACRDEL)
Begin DoDot:1
+54 SET ACRDOC=$SELECT($PIECE(ACRDOC0,U,2)]""&'$DATA(ACRREQST):$PIECE(ACRDOC0,U,2),1:$PIECE(ACRDOC0,U))
+55 SET ACRID=$PIECE(ACRDOC0,U,14)
+56 DO ^ACRFDEL
+57 SET ACRQUIT=""
End DoDot:1
QUIT
+58 QUIT
SETDOC ;EP;TO SET DOCUMENT VARIABLES
+1 IF '$DATA(^ACRDOC(ACRDOCDA,0))!'$DATA(^ACRDOC(ACRDOCDA,"DT"))!($EXTRACT($GET(^ACRDOC(ACRDOCDA,0)),1,5)="^^^^^")!'$DATA(^ACROBL(ACRDOCDA,0))
Begin DoDot:1
+2 ;F DIK="^ACROBL(","^ACRDOC(" S DA=ACRDOCDA D DIK^ACRFDIC ;ACR*2.1*16.14 IM14779
+3 ;ACR*2.1*16.14 IM14779
WRITE !!!,"***** Problems with FMS Document and/or FMS Request files"
+4 ;ACR*2.1*16.14 IM14779
WRITE !,"******* please notify the ARMS Manager immediately!!!!"
+5 ;ACR*2.1*22.09 IM24355
WRITE !,"********* and give them the document ID Number ",ACRDOCDA
+6 ;ACR*2.1*16.14 IM14779
DO PAUSE^ACRFWARN
+7 SET ACRQUIT=""
End DoDot:1
QUIT
+8 SET ACRDOC0=^ACRDOC(ACRDOCDA,0)
+9 SET ACRDOCDT=^ACRDOC(ACRDOCDA,"DT")
+10 SET ACRDOCPO=$GET(^ACRDOC(ACRDOCDA,"PO"))
+11 SET ACROBL0=$GET(^ACROBL(ACRDOCDA,0))
+12 SET ACROBLDT=$GET(^ACROBL(ACRDOCDA,"DT"))
+13 SET ACROBLAP=$GET(^ACROBL(ACRDOCDA,"APV"))
+14 SET ACRID=$PIECE(ACRDOC0,U,14)
+15 SET ACRREFDA=$PIECE(ACRDOC0,U,13)
+16 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+17 SET ACRDOC=$SELECT(ACRREF'=103&(ACRREF'=349)&(ACRREF'=326)&(ACRREF'=210):$PIECE(ACRDOC0,U),1:$PIECE(ACRDOC0,U,2))
+18 SET ACRLBDA=$PIECE(ACRDOC0,U,6)
+19 SET ACRPODA=$PIECE(ACRDOC0,U,8)
+20 SET ACRTXDA=$PIECE(ACRDOC0,U,4)
+21 SET ACRACPT=$PIECE($GET(^ACRPO(+ACRPODA,0)),U,4)
+22 SET ACRACPT=$PIECE($GET(^AUTTACPT(+ACRACPT,0)),U)
+23 IF 'ACRPODA
Begin DoDot:1
+24 NEW DIE,DR,DA
+25 SET ACRPODA=1
+26 SET DA=ACRDOCDA
+27 SET DIE="^ACRDOC("
+28 SET DR=".08////1"
+29 DO DIE^ACRFDIC
End DoDot:1
+30 SET ACRADA=$PIECE(^ACRPO(ACRPODA,0),U,19)
+31 IF 'ACRADA
SET ACRADA=1
+32 QUIT
CANCHK ;EP;TO CHECK FOR REQUIRED CAN DEFAULT DATA
+1 KILL ACRQUIT
+2 NEW ACRI,ACR,ACRX
+3 FOR ACRI=0,"DFLT","DFLT1"
IF '$DATA(^ACRCAN(ACRCANDA,ACRI))
SET ACR=""
DO BADMES
QUIT
+4 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+5 FOR ACRI=1:1:6,8,10:1:22,24,25
IF $PIECE($GET(^ACRCAN(ACRCANDA,"DFLT")),U,ACRI)=""
SET ACRX="D"_ACRI
DO BADCAN
+6 IF $DATA(ACRQUIT)!$DATA(ACROUT)
QUIT
+7 FOR ACRI=3,8,10,11,13:1:15,17,20
IF $PIECE($GET(^ACRCAN(ACRCANDA,"DFLT1")),U,ACRI)=""
SET ACRX="DD"_ACRI
DO BADCAN
+8 IF $DATA(ACR)
DO BADMES
+9 QUIT
BADCAN SET ACRX=$TEXT(@ACRX)
SET ACR($PIECE(ACRX,";;",2))=""
+1 QUIT
BADMES WRITE *7,*7
+1 WRITE !!,"CAN ",@ACRON,ACRFDNCA,@ACROF," has missing default data."
+2 WRITE !,"Notify your systems administrator immediately."
+3 WRITE !
+4 SET ACRX=0
+5 FOR
SET ACRX=$ORDER(ACR(ACRX))
IF 'ACRX
QUIT
Begin DoDot:1
+6 WRITE !?10,$PIECE(^DD(9002186.5,ACRX,0),U)
End DoDot:1
+7 DO PAUSE^ACRFWARN
+8 ;K ACRQUIT ;ACR*2.1*16.02 IM14652
+9 ;ACR*2.1*16.02 IM14652
IF $DATA(ACROUT)
SET ACRQUIT=""
+10 QUIT
NOTIE WRITE *7,*7
+1 WRITE !!,"No TIE UP document has been created for this account. You must create"
+2 WRITE !,"the TIE UP document before obligating any funds for this account."
+3 DO PAUSE^ACRFWARN
+4 SET ACRQUIT=""
+5 QUIT
A1 ;EP;TO PROCESS MODIFICATION
+1 SET ACRDOCDA=ACRAMEND
+2 KILL ACRNOT
+3 DO EN1^ACRFAUTO
+4 SET (DA,ACRDOCDA)=ACROBL2
+5 SET DIE="^ACROBL("
+6 SET DR="903///@;905///@;906///@;909///@;912///@;911///@"
+7 DO DIE^ACRFDIC
+8 SET DA=ACROBL2
+9 SET DIE="^ACRDOC("
+10 SET DR=".15////"_ACRAMEND
+11 DO DIE^ACRFDIC
+12 KILL ACROBL2
+13 DO SETDOC
+14 DO ^ACRFEA41
+15 QUIT
D1 ;;1000
D2 ;;1010
D3 ;;1020
D4 ;;1030
D5 ;;1040
D6 ;;1050
D8 ;;1070
D10 ;;1090
D11 ;;1100
D12 ;;1110
D13 ;;1120
D14 ;;1130
D15 ;;1140
D16 ;;1150
D17 ;;1160
D18 ;;1170
D19 ;;1180
D20 ;;1190
D21 ;;1200
D22 ;;1210
D24 ;;1230
D25 ;;1240
DD3 ;;1250
DD8 ;;1032
DD10 ;;1300
DD11 ;;1310
DD13 ;;1330
DD14 ;;1340
DD15 ;;1350
DD17 ;;1370
DD20 ;;1400
