- ACRFPO2 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING; [ 09/23/2005 9:44 AM ]
- ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- ;;CONTINUATION OF ACRFPO
- EXIT ;EP;
- K ACRDATA,ACRDAT2,ACRDATX,ACRRDATE,ACRPRIOR,ACRDATA1,ACRX,ACRDOC,ACRREF,ACRTXTYP,ACRDOC1,ACRMAX,ACRAPVT,ACRQUIT,ACRDA,ACRDOCDA,ACRGREF,ACRDOCDA,ACRREF1,ACRY,ACRAPDA,ACRLBDA,ACRNOW,ACRNUM,ACRORD,ACRREFDA,ACRSIG,ACRSIGG,ACRPRT
- K ACRSIGP,ACRSIGZ,ACRSIGZZ,ACRFDNO(1),ACRPOA,ACRPO,ACRPPO,ACRPA,ACRXMY,ACRSCRL
- Q
- OBJ ;EP;DETERMINE OBJECT CLASS CODE
- K ACROBJ
- N X,Y,Z
- S X=0
- F S X=$O(^ACRSS("J",ACRDOCDA,X)) Q:'X D
- .S Y=$P($G(^ACRSS(X,0)),U,4)
- .S ACRW=$P($G(^ACRSS(X,"DT")),U,4)
- .I +Y D
- ..S Z=$G(^AUTTOBJC(+Y,0))
- ..S Z=$E($P(Z,U),1,2)
- ..I $L(Z) D
- ...S:'$D(ACR("OBJ",Z)) ACR("OBJ",Z)=""
- ...S ACR("OBJ",Z)=ACR("OBJ",Z)+ACRW
- K ACRW
- S (X,Y)=0
- F S X=$O(ACR("OBJ",X)) Q:'X I ACR("OBJ",X)>Y D
- .S Z=X
- .S Y=ACR("OBJ",X)
- Q:$G(Z)=""
- S ACROBJ=Z_"00"
- K ACR("OBJ")
- Q
- VENDOR ;EP;INCLUDE VENDOR NAME ON DISPLAY
- S DIR(0)="YO"
- S DIR("A")="Display VENDOR's name"
- S DIR("B")="NO"
- S DIR("?")="Enter 'Y' if you want the VENDOR's name displayed."
- W !
- D DIR^ACRFDIC
- Q:$D(ACRQUIT)!$D(ACROUT)
- I Y=1 S ACRSCRL=6
- E S ACRSCRL=10
- Q
- SELECT ;EP;TO SELECT PURCHASE ORDER
- I 'ACRMAX D Q
- .W !?10,"NO PURCHASE ORDERS PENDING"
- .D PAUSE^ACRFWARN
- .S ACRQUIT=""
- K ACRQUIT
- S DIR(0)="LO^1:"_ACRMAX
- S DIR("A")=$S($D(ACRPO):"Which one",1:"Assign NO(S)")
- W !
- D DIR^ACRFDIC
- Q:$D(ACRQUIT)!$D(ACROUT)!(+Y<1)
- N ACRY,ACRI,ACRZI
- S ACRY=Y
- F ACRZI=1:1 S ACRX=$P(ACRY,",",ACRZI) Q:ACRX=""!$D(ACROUT) D Q:$D(ACROUT)
- .S ACRX=+ACRX
- .S ACRXPO=ACRX
- .N ACRENTRY
- .S ACRENTRY="PO"
- .S (DA,ACRDOCDA,ACRZDA,ACRDOCDA)=$P(^TMP("ACRDATA",$J,ACRX),U)
- .S ACRDOC=$P(^TMP("ACRDATA",$J,ACRX),U,4)
- .S ACRTXTYP=$P(^TMP("ACRDATA",$J,ACRX),U,3)
- .D SETDOC^ACRFEA1
- .I $P(ACRDOC0,U,4)=35 S ACRREFX=116
- .E S ACRREFX=$P(ACRDOC0,U,13),ACRREFX=$P(^AUTTDOCR(ACRREFX,0),U)
- .Q:$D(ACRTRANS)
- .I $D(ACRPOA) D
- ..D ASSIGN^ACRFPO1
- ..S ACRPOA=""
- ..K ACRPO
- .I $D(ACRPO)&'$D(ACRPPO) D
- ..D EDIT
- ..K ACRPOA
- ..S ACRPO=""
- .S ACRX=ACRXPO
- .K ACRXPO,ACRIPO
- Q
- AGENT ;EP;TO SELECT PURCHASING AGENT FOR PO REVIEW
- S DIR(0)="YO"
- S DIR("A")="Display documents assigned to one PURCHASING AGENT only"
- S DIR("B")="NO"
- S DIR("?")="Enter 'Y' to display only documents assigned to a specified purchasing agent."
- W !
- D DIR^ACRFDIC
- Q:$D(ACRQUIT)!$D(ACROUT)
- I +Y'=1 K ACRDUZ,ACRREV Q
- S DIC="^ACRPA("
- S DIC("A")="Which PURCHASING AGENT: "
- S DIC(0)="AEMQZ"
- W !
- D DIC^ACRFDIC
- I $E(X)=U!$D(DTOUT)!$D(DUOUT) S ACRQUIT="" Q
- S ACRDUZ=+Y
- S ACRPO=""
- Q
- TEMP ;EP;TEMP MESSAGE
- W @IOF,*7,*7,*7
- W !?10,"*** PURCHASING SUPERVISOR PLEASE NOTE THE FOLLOWING ***"
- W !?5,"A slight modification has been made to allow ARMS to work better with"
- W !?5,"requisitions created to produce CONTRACTs rather than PURCHASE ORDERs."
- W !!?5,"The CONTRACT module of ARMS is still not yet completed. However,"
- W !?5,"if you select '2' below for requisitions which are intended to initiate a"
- W !?5,"CONTRACT action, ARMS will allow you to proceed with assigning the document"
- W !?5,"to a contract or purchasing agent. The BASIC data can be completed and"
- W !?5,"the document sent for approval and 'signed.' This will allow the initiator"
- W !?5,"to use ARMS to initiate and track the document throughout the process"
- W !?5,"and get the dollars recorded against their DEPARTMENT ACCOUNT."
- W !?5,"However, NO CIS (Contract Information System) entry will be created."
- W !?5,"The document will be 'set aside' by ARMS and can be processed manually"
- W !?5,"as a new CONTRACT or CONTRACT action."
- W !!?5,"Therefore, ALL ARMS requisitions which are intended to initiate a"
- W !?5,"CONTRACT action should be coded as a '2' for 'Contract'd."
- Q
- HEAD ;EP;
- W:$D(IOF)&'$D(ACRTRANS)&'$D(ACRREV) @IOF
- W $S($D(ACRPO)!$D(ACRPPO):"Select PURCHASE ORDER:",1:"Select REQUEST to ASSIGN TO PURCHASING AGENT")
- W !!?2,"NO."
- W ?9,"REQUEST NO."
- W ?24,"RQD BY/OBJ CD/$$"
- W ?40,"| NO."
- W ?50,"REQUEST NO."
- W ?65,"RQD BY/OBJ CD/$"
- W !,"------"
- W ?7,"----------------"
- W ?24,"----------------"
- W ?40,"|------"
- W ?48,"----------------"
- W ?65,"---------------"
- Q
- ASSONE ;EP;TO ASSIGN ONE DOCUMENT ONLY
- K ACRPO
- S ACRPOA=""
- S DIR(0)="SO^1:Assign ONE Document Only;2:List ALL Pending PO's;3:Transfer Unsigned PO's to new Agent"
- W !
- D DIR^ACRFDIC
- I $D(ACRQUIT)!$D(ACROUT)!(123'[+Y) S ACRQUIT="" Q
- Q:Y=2
- I Y=3 D TRANS Q
- ONE ;EP;
- D LOOKUP^ACRFPO3
- K ACRREFZ,ACRAPV
- I $D(ACRQUIT)!$D(ACROUT) K ACRQUIT
- N ACRENTRY
- S ACRENTRY="PO",ACRONE=""
- D ASSIGN^ACRFPO1
- Q
- EDIT ;EP;
- S ACRENTRY=$T(@ACRENTRY^ACRFCTL1)
- S ACRPO=""
- K ACRPOA
- D SET^ACRFEA
- D ^ACRFEA4
- K ACRPRCS
- Q
- TRANS ;EP;TO TRANSFER ALL ACTIVE/UNSIGNED PO'S TO NEW PA
- N ACRPA1,ACRPA2
- S DIC="^ACRPA("
- S DIC(0)="AEMQZ"
- S DIC("A")="Purchasing Agent: "
- W !!,"Transfer PO's FROM"
- D DIC^ACRFDIC
- I Y<1 W !,"No Purchasing Agent selected." H 2 Q
- S ACRPA1=+Y
- S DIC="^ACRPA("
- S DIC(0)="AEMQZ"
- S DIC("A")="Purchasing Agent: "
- W !!,"Transfer PO's TO"
- D DIC^ACRFDIC
- I Y<1 W !,"No Purchasing Agent selected." H 2 Q
- S ACRPA2=+Y
- D T1
- S ACRQUIT=""
- Q
- T1 S (ACRDOCDA,ACRJ)=0
- F S ACRDOCDA=$O(^ACRDOC("PA",ACRPA1,ACRDOCDA)) Q:'ACRDOCDA I $E($G(^ACROBL(ACRDOCDA,"APV")))="A",$P(^("APV"),U,8)="" S ACRJ=ACRJ+1
- W !!?10,"All ",@ACRON,ACRJ,@ACROF," unsigned PO's"
- ;W !?10,"currently assigned to: ",$P($G(^VA(200,ACRPA1,0)),U) ;ACR*2.1*19.02 IM16848
- ;W !?10,"will be re-assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
- W !?10,"currently assigned to: ",$$NAME2^ACRFUTL1(ACRPA1) ;ACR*2.1*19.02 IM16848
- W !?10,"will be re-assigned to: ",$$NAME2^ACRFUTL1(ACRPA2) ;ACR*2.1*19.02 IM16848
- S DIR(0)="YO"
- S DIR("A",1)="Are you certain you want"
- S DIR("A")="to make this transfer"
- S DIR("B")="NO"
- W !
- D DIR^ACRFDIC
- I Y'=1 S ACRQUIT="" Q
- D T2
- Q
- T2 S ACRDOCDA=0
- F S ACRDOCDA=$O(^ACRDOC("PA",ACRPA1,ACRDOCDA)) Q:'ACRDOCDA I $E($G(^ACROBL(ACRDOCDA,"APV")))="A",$P(^("APV"),U,8)="" D
- .S DA=ACRDOCDA
- .S DIE="^ACRDOC("
- .S DR=".2////"_ACRPA2
- .D DIE^ACRFDIC
- .;W !,$P(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
- .W !,$P(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$$NAME2^ACRFUTL1(ACRPA2) ;ACR*2.1*19.02 IM16848
- Q
- ACRFPO2 ;IHS/OIRM/DSD/THL,AEF - PURCHASE ORDER PROCESSING; [ 09/23/2005 9:44 AM ]
- +1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**19**;NOV 05, 2001
- +2 ;;CONTINUATION OF ACRFPO
- EXIT ;EP;
- +1 KILL ACRDATA,ACRDAT2,ACRDATX,ACRRDATE,ACRPRIOR,ACRDATA1,ACRX,ACRDOC,ACRREF,ACRTXTYP,ACRDOC1,ACRMAX,ACRAPVT,ACRQUIT,ACRDA,ACRDOCDA,ACRGREF,ACRDOCDA,ACRREF1,ACRY,ACRAPDA,ACRLBDA,ACRNOW,ACRNUM,ACRORD,ACRREFDA,ACRSIG,ACRSIGG,ACRPRT
- +2 KILL ACRSIGP,ACRSIGZ,ACRSIGZZ,ACRFDNO(1),ACRPOA,ACRPO,ACRPPO,ACRPA,ACRXMY,ACRSCRL
- +3 QUIT
- OBJ ;EP;DETERMINE OBJECT CLASS CODE
- +1 KILL ACROBJ
- +2 NEW X,Y,Z
- +3 SET X=0
- +4 FOR
- SET X=$ORDER(^ACRSS("J",ACRDOCDA,X))
- IF 'X
- QUIT
- Begin DoDot:1
- +5 SET Y=$PIECE($GET(^ACRSS(X,0)),U,4)
- +6 SET ACRW=$PIECE($GET(^ACRSS(X,"DT")),U,4)
- +7 IF +Y
- Begin DoDot:2
- +8 SET Z=$GET(^AUTTOBJC(+Y,0))
- +9 SET Z=$EXTRACT($PIECE(Z,U),1,2)
- +10 IF $LENGTH(Z)
- Begin DoDot:3
- +11 IF '$DATA(ACR("OBJ",Z))
- SET ACR("OBJ",Z)=""
- +12 SET ACR("OBJ",Z)=ACR("OBJ",Z)+ACRW
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 KILL ACRW
- +14 SET (X,Y)=0
- +15 FOR
- SET X=$ORDER(ACR("OBJ",X))
- IF 'X
- QUIT
- IF ACR("OBJ",X)>Y
- Begin DoDot:1
- +16 SET Z=X
- +17 SET Y=ACR("OBJ",X)
- End DoDot:1
- +18 IF $GET(Z)=""
- QUIT
- +19 SET ACROBJ=Z_"00"
- +20 KILL ACR("OBJ")
- +21 QUIT
- VENDOR ;EP;INCLUDE VENDOR NAME ON DISPLAY
- +1 SET DIR(0)="YO"
- +2 SET DIR("A")="Display VENDOR's name"
- +3 SET DIR("B")="NO"
- +4 SET DIR("?")="Enter 'Y' if you want the VENDOR's name displayed."
- +5 WRITE !
- +6 DO DIR^ACRFDIC
- +7 IF $DATA(ACRQUIT)!$DATA(ACROUT)
- QUIT
- +8 IF Y=1
- SET ACRSCRL=6
- +9 IF '$TEST
- SET ACRSCRL=10
- +10 QUIT
- SELECT ;EP;TO SELECT PURCHASE ORDER
- +1 IF 'ACRMAX
- Begin DoDot:1
- +2 WRITE !?10,"NO PURCHASE ORDERS PENDING"
- +3 DO PAUSE^ACRFWARN
- +4 SET ACRQUIT=""
- End DoDot:1
- QUIT
- +5 KILL ACRQUIT
- +6 SET DIR(0)="LO^1:"_ACRMAX
- +7 SET DIR("A")=$SELECT($DATA(ACRPO):"Which one",1:"Assign NO(S)")
- +8 WRITE !
- +9 DO DIR^ACRFDIC
- +10 IF $DATA(ACRQUIT)!$DATA(ACROUT)!(+Y<1)
- QUIT
- +11 NEW ACRY,ACRI,ACRZI
- +12 SET ACRY=Y
- +13 FOR ACRZI=1:1
- SET ACRX=$PIECE(ACRY,",",ACRZI)
- IF ACRX=""!$DATA(ACROUT)
- QUIT
- Begin DoDot:1
- +14 SET ACRX=+ACRX
- +15 SET ACRXPO=ACRX
- +16 NEW ACRENTRY
- +17 SET ACRENTRY="PO"
- +18 SET (DA,ACRDOCDA,ACRZDA,ACRDOCDA)=$PIECE(^TMP("ACRDATA",$JOB,ACRX),U)
- +19 SET ACRDOC=$PIECE(^TMP("ACRDATA",$JOB,ACRX),U,4)
- +20 SET ACRTXTYP=$PIECE(^TMP("ACRDATA",$JOB,ACRX),U,3)
- +21 DO SETDOC^ACRFEA1
- +22 IF $PIECE(ACRDOC0,U,4)=35
- SET ACRREFX=116
- +23 IF '$TEST
- SET ACRREFX=$PIECE(ACRDOC0,U,13)
- SET ACRREFX=$PIECE(^AUTTDOCR(ACRREFX,0),U)
- +24 IF $DATA(ACRTRANS)
- QUIT
- +25 IF $DATA(ACRPOA)
- Begin DoDot:2
- +26 DO ASSIGN^ACRFPO1
- +27 SET ACRPOA=""
- +28 KILL ACRPO
- End DoDot:2
- +29 IF $DATA(ACRPO)&'$DATA(ACRPPO)
- Begin DoDot:2
- +30 DO EDIT
- +31 KILL ACRPOA
- +32 SET ACRPO=""
- End DoDot:2
- +33 SET ACRX=ACRXPO
- +34 KILL ACRXPO,ACRIPO
- End DoDot:1
- IF $DATA(ACROUT)
- QUIT
- +35 QUIT
- AGENT ;EP;TO SELECT PURCHASING AGENT FOR PO REVIEW
- +1 SET DIR(0)="YO"
- +2 SET DIR("A")="Display documents assigned to one PURCHASING AGENT only"
- +3 SET DIR("B")="NO"
- +4 SET DIR("?")="Enter 'Y' to display only documents assigned to a specified purchasing agent."
- +5 WRITE !
- +6 DO DIR^ACRFDIC
- +7 IF $DATA(ACRQUIT)!$DATA(ACROUT)
- QUIT
- +8 IF +Y'=1
- KILL ACRDUZ,ACRREV
- QUIT
- +9 SET DIC="^ACRPA("
- +10 SET DIC("A")="Which PURCHASING AGENT: "
- +11 SET DIC(0)="AEMQZ"
- +12 WRITE !
- +13 DO DIC^ACRFDIC
- +14 IF $EXTRACT(X)=U!$DATA(DTOUT)!$DATA(DUOUT)
- SET ACRQUIT=""
- QUIT
- +15 SET ACRDUZ=+Y
- +16 SET ACRPO=""
- +17 QUIT
- TEMP ;EP;TEMP MESSAGE
- +1 WRITE @IOF,*7,*7,*7
- +2 WRITE !?10,"*** PURCHASING SUPERVISOR PLEASE NOTE THE FOLLOWING ***"
- +3 WRITE !?5,"A slight modification has been made to allow ARMS to work better with"
- +4 WRITE !?5,"requisitions created to produce CONTRACTs rather than PURCHASE ORDERs."
- +5 WRITE !!?5,"The CONTRACT module of ARMS is still not yet completed. However,"
- +6 WRITE !?5,"if you select '2' below for requisitions which are intended to initiate a"
- +7 WRITE !?5,"CONTRACT action, ARMS will allow you to proceed with assigning the document"
- +8 WRITE !?5,"to a contract or purchasing agent. The BASIC data can be completed and"
- +9 WRITE !?5,"the document sent for approval and 'signed.' This will allow the initiator"
- +10 WRITE !?5,"to use ARMS to initiate and track the document throughout the process"
- +11 WRITE !?5,"and get the dollars recorded against their DEPARTMENT ACCOUNT."
- +12 WRITE !?5,"However, NO CIS (Contract Information System) entry will be created."
- +13 WRITE !?5,"The document will be 'set aside' by ARMS and can be processed manually"
- +14 WRITE !?5,"as a new CONTRACT or CONTRACT action."
- +15 WRITE !!?5,"Therefore, ALL ARMS requisitions which are intended to initiate a"
- +16 WRITE !?5,"CONTRACT action should be coded as a '2' for 'Contract'd."
- +17 QUIT
- HEAD ;EP;
- +1 IF $DATA(IOF)&'$DATA(ACRTRANS)&'$DATA(ACRREV)
- WRITE @IOF
- +2 WRITE $SELECT($DATA(ACRPO)!$DATA(ACRPPO):"Select PURCHASE ORDER:",1:"Select REQUEST to ASSIGN TO PURCHASING AGENT")
- +3 WRITE !!?2,"NO."
- +4 WRITE ?9,"REQUEST NO."
- +5 WRITE ?24,"RQD BY/OBJ CD/$$"
- +6 WRITE ?40,"| NO."
- +7 WRITE ?50,"REQUEST NO."
- +8 WRITE ?65,"RQD BY/OBJ CD/$"
- +9 WRITE !,"------"
- +10 WRITE ?7,"----------------"
- +11 WRITE ?24,"----------------"
- +12 WRITE ?40,"|------"
- +13 WRITE ?48,"----------------"
- +14 WRITE ?65,"---------------"
- +15 QUIT
- ASSONE ;EP;TO ASSIGN ONE DOCUMENT ONLY
- +1 KILL ACRPO
- +2 SET ACRPOA=""
- +3 SET DIR(0)="SO^1:Assign ONE Document Only;2:List ALL Pending PO's;3:Transfer Unsigned PO's to new Agent"
- +4 WRITE !
- +5 DO DIR^ACRFDIC
- +6 IF $DATA(ACRQUIT)!$DATA(ACROUT)!(123'[+Y)
- SET ACRQUIT=""
- QUIT
- +7 IF Y=2
- QUIT
- +8 IF Y=3
- DO TRANS
- QUIT
- ONE ;EP;
- +1 DO LOOKUP^ACRFPO3
- +2 KILL ACRREFZ,ACRAPV
- +3 IF $DATA(ACRQUIT)!$DATA(ACROUT)
- KILL ACRQUIT
- +4 NEW ACRENTRY
- +5 SET ACRENTRY="PO"
- SET ACRONE=""
- +6 DO ASSIGN^ACRFPO1
- +7 QUIT
- EDIT ;EP;
- +1 SET ACRENTRY=$TEXT(@ACRENTRY^ACRFCTL1)
- +2 SET ACRPO=""
- +3 KILL ACRPOA
- +4 DO SET^ACRFEA
- +5 DO ^ACRFEA4
- +6 KILL ACRPRCS
- +7 QUIT
- TRANS ;EP;TO TRANSFER ALL ACTIVE/UNSIGNED PO'S TO NEW PA
- +1 NEW ACRPA1,ACRPA2
- +2 SET DIC="^ACRPA("
- +3 SET DIC(0)="AEMQZ"
- +4 SET DIC("A")="Purchasing Agent: "
- +5 WRITE !!,"Transfer PO's FROM"
- +6 DO DIC^ACRFDIC
- +7 IF Y<1
- WRITE !,"No Purchasing Agent selected."
- HANG 2
- QUIT
- +8 SET ACRPA1=+Y
- +9 SET DIC="^ACRPA("
- +10 SET DIC(0)="AEMQZ"
- +11 SET DIC("A")="Purchasing Agent: "
- +12 WRITE !!,"Transfer PO's TO"
- +13 DO DIC^ACRFDIC
- +14 IF Y<1
- WRITE !,"No Purchasing Agent selected."
- HANG 2
- QUIT
- +15 SET ACRPA2=+Y
- +16 DO T1
- +17 SET ACRQUIT=""
- +18 QUIT
- T1 SET (ACRDOCDA,ACRJ)=0
- +1 FOR
- SET ACRDOCDA=$ORDER(^ACRDOC("PA",ACRPA1,ACRDOCDA))
- IF 'ACRDOCDA
- QUIT
- IF $EXTRACT($GET(^ACROBL(ACRDOCDA,"APV")))="A"
- IF $PIECE(^("APV"),U,8)=""
- SET ACRJ=ACRJ+1
- +2 WRITE !!?10,"All ",@ACRON,ACRJ,@ACROF," unsigned PO's"
- +3 ;W !?10,"currently assigned to: ",$P($G(^VA(200,ACRPA1,0)),U) ;ACR*2.1*19.02 IM16848
- +4 ;W !?10,"will be re-assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
- +5 ;ACR*2.1*19.02 IM16848
- WRITE !?10,"currently assigned to: ",$$NAME2^ACRFUTL1(ACRPA1)
- +6 ;ACR*2.1*19.02 IM16848
- WRITE !?10,"will be re-assigned to: ",$$NAME2^ACRFUTL1(ACRPA2)
- +7 SET DIR(0)="YO"
- +8 SET DIR("A",1)="Are you certain you want"
- +9 SET DIR("A")="to make this transfer"
- +10 SET DIR("B")="NO"
- +11 WRITE !
- +12 DO DIR^ACRFDIC
- +13 IF Y'=1
- SET ACRQUIT=""
- QUIT
- +14 DO T2
- +15 QUIT
- T2 SET ACRDOCDA=0
- +1 FOR
- SET ACRDOCDA=$ORDER(^ACRDOC("PA",ACRPA1,ACRDOCDA))
- IF 'ACRDOCDA
- QUIT
- IF $EXTRACT($GET(^ACROBL(ACRDOCDA,"APV")))="A"
- IF $PIECE(^("APV"),U,8)=""
- Begin DoDot:1
- +2 SET DA=ACRDOCDA
- +3 SET DIE="^ACRDOC("
- +4 SET DR=".2////"_ACRPA2
- +5 DO DIE^ACRFDIC
- +6 ;W !,$P(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$P($G(^VA(200,ACRPA2,0)),U) ;ACR*2.1*19.02 IM16848
- +7 ;ACR*2.1*19.02 IM16848
- WRITE !,$PIECE(^ACRDOC(ACRDOCDA,0),U),?15," now assigned to: ",$$NAME2^ACRFUTL1(ACRPA2)
- End DoDot:1
- +8 QUIT