- 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
