ACRFDOCN ;IHS/OIRM/DSD/THL,AEF - SET DOCUMENT NUMBER; [ 11/30/2006 9:44 AM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**22**;NOV 05, 2001
;;ROUTINE USED TO CREATE DOCUMENT NUMBER
DOC ;EP;TO ASSIGN DOCUMENT NUMBERS
I $D(ACRAMEND),$D(^ACRDOC(ACRAMEND,0)) D DOCAMEND Q
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
I ACRREF=130!(ACRREF=600) D Q
.S ACRREF=130
.D TO
PONUM1 I "^103^210^"[(U_ACRREF_U) D
.N ACRFY
.S ACRFY=$P(^ACRLOCB($P(ACRDOC0,U,6),"DT"),U)
.S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
.S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
.I '$D(^ACRPO(ACRPODA,1,0)) S ^ACRPO(ACRPODA,1,0)="^9002199.41"
.I '$D(^ACRPO(ACRPODA,1,"B",ACRFYX)) D
..S (X,DINUM)=ACRFYX
..S DA(1)=ACRPODA
..S DIC="^ACRPO("_DA(1)_",1,"
..S DIC(0)="L"
..D FILE^ACRFDIC
.L +^ACRPO(ACRPODA):2
.I $T=1 S ACRTXDOC=$P(^ACRPO(ACRPODA,1,ACRFYX,0),U,2),ACRTXDOC=ACRTXDOC+1,$P(^(0),U,2)=ACRTXDOC L -^ACRPO(ACRPODA):0
.E G PONUM1
.F ACRJI=1:1:(4-$L(ACRTXDOC)) S ACRTXDOC="0"_ACRTXDOC
.S ACRTXDOC=ACRTXDOC_"00"
S ACRTXPFX=$P(^ACRTXTYP(ACRTXDA,"DT"),U,2)
S ACRDPTDA=$P(^ACRLOCB(ACRFDNO,0),U,5)
S ACRLCOD=$P(^ACRLOCB(ACRFDNO,"DT"),U,11)
S ACRDEPT=$P(^AUTTPRG(ACRDPTDA,0),U,2)
S ACRPDA=$P(^ACRCAN(ACRCANDA,"DFLT1"),U,15)
S ACRAREA=$S('ACRPDA:"",$D(^ACRPO(ACRPDA,0)):$P(^(0),U,10),1:"")
I 'ACRPDA D Q
.W *7,*7
.W !!,"The Purchasing Office for the CAN NO. default data has not been defined."
.W !,"Notify the ARMS systems manager immediately."
.D PAUSE^ACRFWARN
.S ACRQUIT=""
I 'ACRAREA D Q
.W *7,*7
.W !!,"The Area Office of your Purchasing Office has not been identified."
.W !,"Notify the ARMS systems manager immediately."
.S ACRQUIT=""
.D PAUSE^ACRFWARN
I 'ACRLCOD D Q
.W *7,*7
.W !!,"The location code of your Purchasing Office has not been identified."
.W !,"Notify the ARMS systems manager immediately."
.D PAUSE^ACRFWARN
.S ACRQUIT=""
S ACRLCOD=$P(^AUTTLCOD(ACRLCOD,0),U)
S ACRAREA=$P(^AUTTAREA(ACRAREA,0),U,3)
G:"^103^210^"[(U_ACRREF_U) DOC3
DOC1 ;EP;
S ACRFY=$P(^ACRLOCB(ACRFDNO,"DT"),U)
S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
I '$D(^ACRDEPT(ACRDPTDA,0)) D
.S (X,DINUM)=ACRDPTDA
.S DIC="^ACRDEPT(",DIC(0)="L"
.D FILE^ACRFDIC
I '$D(^ACRDEPT(ACRDPTDA,1,0)) S ^ACRDEPT(ACRDPTDA,1,0)="^9002188.11"
I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,0)) D
.S DA(1)=ACRDPTDA
.S (DINUM,X)=ACRFYX
.S (ACRDIC,DIC)="^ACRDEPT("_DA(1)_",1,"
.S DIC(0)="L"
.D FILE^ACRFDIC
I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0)) S ^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0)="^9002188.112P"
I '$D(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA)) D
.S DA(2)=ACRDPTDA
.S DA(1)=ACRFYX
.S (DINUM,X)=ACRREFDA
.S (ACRDIC,DIC)="^ACRDEPT("_DA(2)_",1,"_DA(1)_",1,"
.S DIC(0)="L"
.D FILE^ACRFDIC
DOC11 L +^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):2
I $T=1 D I 1
.S ACRTXDOC=$P(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)
.S ACRTXDOC=ACRTXDOC+1
.S $P(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)=ACRTXDOC
.L -^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):0
E G DOC11
F ACRJI=1:1:(4-$L(ACRTXDOC)) S ACRTXDOC="0"_ACRTXDOC
K ACRJI
DOC3 S ACRFY=$P(^ACRLOCB(ACRZDA,"DT"),U)
S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
S ACRDOC=$S(ACRREF=116!(ACRREF=101):ACRLCOD_"-"_ACRDEPT_"-"_$E(ACRFYX,4)_"-"_ACRTXDOC,ACRREF=103!(ACRREF=210):$E(ACRFYX,4)_ACRAREA_ACRLCOD_ACRTXDOC,1:$E(ACRFYX,4)_ACRTXPFX_ACRDEPT_ACRTXDOC)
;I "^103^210^"'[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC)) G DOC11 ;ACR*2.1*22.07 IM22855
;I "^103^210^"[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC))!$D(^ACRDOC("C",ACRDOC)) G DOC11 ;ACR*2.1*22.07 IM22855
I $D(^ACRDOC("B",ACRDOC))!($D(^ACRDOC("C",ACRDOC)))!($D(^ACRDOC("O",ACRDOC))) G DOC11 ;ACR*2.1*22.07 IM22855
K ACRFYX
Q
TO ;EP;
N ACRFY
S ACRFY=$P(^ACRLOCB(ACRFDNO,"DT"),U)
S ACRLC=$P(^ACRLOCB(ACRFDNO,"DT"),U,11)
S ACRFYX=$S(+$E(DT,4,5)<10:$E(DT,1,3),1:$E(DT,1,3)+1) S ACRFYX=ACRFYX+1700
S ACRFYX=$S(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
I '$D(^ACRPO(1,20,0)) S ^ACRPO(1,20,0)="^9002199.4201"
I '$D(^ACRPO(1,20,"B",ACRFY)) D
.S DA(1)=1
.S (X,DINUM)=ACRFY
.S DIC="^ACRPO(1,20,"
.S DIC(0)="L"
.S DIC("DR")=".02///0"
.D FILE^ACRFDIC
TO1 L +^ACRPO(1):2
I $T=1 D I 1
.S ACRNUM=$P(^ACRPO(1,20,ACRFY,0),U,2)
.S ACRNUM=ACRNUM+1
.S $P(^ACRPO(1,20,ACRFY,0),U,2)=ACRNUM
.S ACRAPT=$P(^ACRPO(1,0),U,4)
.S ACRAREA=$P(^ACRPO(1,0),U,10)
.L -^ACRPO(1):0
E G TO1
F ACRJI=1:1:(4-$L(ACRNUM)) S ACRNUM="0"_ACRNUM
S (ACRDOC,ACRNUM)=$E(ACRFYX,4)_$E($P(^AUTTLCOD(ACRLC,0),U),1,3)_"TO"_ACRNUM
I $D(^ACRDOC("B",ACRNUM)) G TO1
K ACRFYX
Q
DOCAMEND L +^ACRDOC(ACRAMEND,0):2
G:'$T DOCAMEND
S X=$P(^ACRDOC(ACRAMEND,0),U,9)
S X=X+1
S $P(^ACRDOC(ACRAMEND,0),U,9)=X
L -^ACRDOC(ACRAMEND,0):0
F Y=1:1:3-$L(X) S X="0"_X
N ACRREFDA,ACRREF
S ACRDOC=$P(^ACRDOC(ACRAMEND,0),U)_X
S ACRANUM=X
S ACRDOC2=$P(^ACRDOC(ACRAMEND,0),U,2)
S ACRREFDA=$P(^ACRDOC(ACRAMEND,0),U,13)
S ACRREF=$P(^AUTTDOCR(ACRREFDA,0),U)
Q
ACRFDOCN ;IHS/OIRM/DSD/THL,AEF - SET DOCUMENT NUMBER; [ 11/30/2006 9:44 AM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**22**;NOV 05, 2001
+2 ;;ROUTINE USED TO CREATE DOCUMENT NUMBER
DOC ;EP;TO ASSIGN DOCUMENT NUMBERS
+1 IF $DATA(ACRAMEND)
IF $DATA(^ACRDOC(ACRAMEND,0))
DO DOCAMEND
QUIT
+2 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+3 IF ACRREF=130!(ACRREF=600)
Begin DoDot:1
+4 SET ACRREF=130
+5 DO TO
End DoDot:1
QUIT
PONUM1 IF "^103^210^"[(U_ACRREF_U)
Begin DoDot:1
+1 NEW ACRFY
+2 SET ACRFY=$PIECE(^ACRLOCB($PIECE(ACRDOC0,U,6),"DT"),U)
+3 SET ACRFYX=$SELECT(+$EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3),1:$EXTRACT(DT,1,3)+1)
SET ACRFYX=ACRFYX+1700
+4 SET ACRFYX=$SELECT(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
+5 IF '$DATA(^ACRPO(ACRPODA,1,0))
SET ^ACRPO(ACRPODA,1,0)="^9002199.41"
+6 IF '$DATA(^ACRPO(ACRPODA,1,"B",ACRFYX))
Begin DoDot:2
+7 SET (X,DINUM)=ACRFYX
+8 SET DA(1)=ACRPODA
+9 SET DIC="^ACRPO("_DA(1)_",1,"
+10 SET DIC(0)="L"
+11 DO FILE^ACRFDIC
End DoDot:2
+12 LOCK +^ACRPO(ACRPODA):2
+13 IF $TEST=1
SET ACRTXDOC=$PIECE(^ACRPO(ACRPODA,1,ACRFYX,0),U,2)
SET ACRTXDOC=ACRTXDOC+1
SET $PIECE(^(0),U,2)=ACRTXDOC
LOCK -^ACRPO(ACRPODA):0
+14 IF '$TEST
GOTO PONUM1
+15 FOR ACRJI=1:1:(4-$LENGTH(ACRTXDOC))
SET ACRTXDOC="0"_ACRTXDOC
+16 SET ACRTXDOC=ACRTXDOC_"00"
End DoDot:1
+17 SET ACRTXPFX=$PIECE(^ACRTXTYP(ACRTXDA,"DT"),U,2)
+18 SET ACRDPTDA=$PIECE(^ACRLOCB(ACRFDNO,0),U,5)
+19 SET ACRLCOD=$PIECE(^ACRLOCB(ACRFDNO,"DT"),U,11)
+20 SET ACRDEPT=$PIECE(^AUTTPRG(ACRDPTDA,0),U,2)
+21 SET ACRPDA=$PIECE(^ACRCAN(ACRCANDA,"DFLT1"),U,15)
+22 SET ACRAREA=$SELECT('ACRPDA:"",$DATA(^ACRPO(ACRPDA,0)):$PIECE(^(0),U,10),1:"")
+23 IF 'ACRPDA
Begin DoDot:1
+24 WRITE *7,*7
+25 WRITE !!,"The Purchasing Office for the CAN NO. default data has not been defined."
+26 WRITE !,"Notify the ARMS systems manager immediately."
+27 DO PAUSE^ACRFWARN
+28 SET ACRQUIT=""
End DoDot:1
QUIT
+29 IF 'ACRAREA
Begin DoDot:1
+30 WRITE *7,*7
+31 WRITE !!,"The Area Office of your Purchasing Office has not been identified."
+32 WRITE !,"Notify the ARMS systems manager immediately."
+33 SET ACRQUIT=""
+34 DO PAUSE^ACRFWARN
End DoDot:1
QUIT
+35 IF 'ACRLCOD
Begin DoDot:1
+36 WRITE *7,*7
+37 WRITE !!,"The location code of your Purchasing Office has not been identified."
+38 WRITE !,"Notify the ARMS systems manager immediately."
+39 DO PAUSE^ACRFWARN
+40 SET ACRQUIT=""
End DoDot:1
QUIT
+41 SET ACRLCOD=$PIECE(^AUTTLCOD(ACRLCOD,0),U)
+42 SET ACRAREA=$PIECE(^AUTTAREA(ACRAREA,0),U,3)
+43 IF "^103^210^"[(U_ACRREF_U)
GOTO DOC3
DOC1 ;EP;
+1 SET ACRFY=$PIECE(^ACRLOCB(ACRFDNO,"DT"),U)
+2 SET ACRFYX=$SELECT(+$EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3),1:$EXTRACT(DT,1,3)+1)
SET ACRFYX=ACRFYX+1700
+3 SET ACRFYX=$SELECT(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
+4 IF '$DATA(^ACRDEPT(ACRDPTDA,0))
Begin DoDot:1
+5 SET (X,DINUM)=ACRDPTDA
+6 SET DIC="^ACRDEPT("
SET DIC(0)="L"
+7 DO FILE^ACRFDIC
End DoDot:1
+8 IF '$DATA(^ACRDEPT(ACRDPTDA,1,0))
SET ^ACRDEPT(ACRDPTDA,1,0)="^9002188.11"
+9 IF '$DATA(^ACRDEPT(ACRDPTDA,1,ACRFYX,0))
Begin DoDot:1
+10 SET DA(1)=ACRDPTDA
+11 SET (DINUM,X)=ACRFYX
+12 SET (ACRDIC,DIC)="^ACRDEPT("_DA(1)_",1,"
+13 SET DIC(0)="L"
+14 DO FILE^ACRFDIC
End DoDot:1
+15 IF '$DATA(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0))
SET ^ACRDEPT(ACRDPTDA,1,ACRFYX,1,0)="^9002188.112P"
+16 IF '$DATA(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA))
Begin DoDot:1
+17 SET DA(2)=ACRDPTDA
+18 SET DA(1)=ACRFYX
+19 SET (DINUM,X)=ACRREFDA
+20 SET (ACRDIC,DIC)="^ACRDEPT("_DA(2)_",1,"_DA(1)_",1,"
+21 SET DIC(0)="L"
+22 DO FILE^ACRFDIC
End DoDot:1
DOC11 LOCK +^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):2
+1 IF $TEST=1
Begin DoDot:1
+2 SET ACRTXDOC=$PIECE(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)
+3 SET ACRTXDOC=ACRTXDOC+1
+4 SET $PIECE(^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0),U,2)=ACRTXDOC
+5 LOCK -^ACRDEPT(ACRDPTDA,1,ACRFYX,1,ACRREFDA,0):0
End DoDot:1
IF 1
+6 IF '$TEST
GOTO DOC11
+7 FOR ACRJI=1:1:(4-$LENGTH(ACRTXDOC))
SET ACRTXDOC="0"_ACRTXDOC
+8 KILL ACRJI
DOC3 SET ACRFY=$PIECE(^ACRLOCB(ACRZDA,"DT"),U)
+1 SET ACRFYX=$SELECT(+$EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3),1:$EXTRACT(DT,1,3)+1)
SET ACRFYX=ACRFYX+1700
+2 SET ACRFYX=$SELECT(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
+3 SET ACRDOC=$SELECT(ACRREF=116!(ACRREF=101):ACRLCOD_"-"_ACRDEPT_"-"_$EXTRACT(ACRFYX,4)_"-"_ACRTXDOC,ACRREF=103!(ACRREF=210):$EXTRACT(ACRFYX,4)_ACRAREA_ACRLCOD_ACRTXDOC,1:$EXTRACT(ACRFYX,4)_ACRTXPFX_ACRDEPT_ACRTXDOC)
+4 ;I "^103^210^"'[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC)) G DOC11 ;ACR*2.1*22.07 IM22855
+5 ;I "^103^210^"[(U_ACRREF_U),$D(^ACRDOC("B",ACRDOC))!$D(^ACRDOC("C",ACRDOC)) G DOC11 ;ACR*2.1*22.07 IM22855
+6 ;ACR*2.1*22.07 IM22855
IF $DATA(^ACRDOC("B",ACRDOC))!($DATA(^ACRDOC("C",ACRDOC)))!($DATA(^ACRDOC("O",ACRDOC)))
GOTO DOC11
+7 KILL ACRFYX
+8 QUIT
TO ;EP;
+1 NEW ACRFY
+2 SET ACRFY=$PIECE(^ACRLOCB(ACRFDNO,"DT"),U)
+3 SET ACRLC=$PIECE(^ACRLOCB(ACRFDNO,"DT"),U,11)
+4 SET ACRFYX=$SELECT(+$EXTRACT(DT,4,5)<10:$EXTRACT(DT,1,3),1:$EXTRACT(DT,1,3)+1)
SET ACRFYX=ACRFYX+1700
+5 SET ACRFYX=$SELECT(ACRFYX>ACRFY:ACRFYX,1:ACRFY)
+6 IF '$DATA(^ACRPO(1,20,0))
SET ^ACRPO(1,20,0)="^9002199.4201"
+7 IF '$DATA(^ACRPO(1,20,"B",ACRFY))
Begin DoDot:1
+8 SET DA(1)=1
+9 SET (X,DINUM)=ACRFY
+10 SET DIC="^ACRPO(1,20,"
+11 SET DIC(0)="L"
+12 SET DIC("DR")=".02///0"
+13 DO FILE^ACRFDIC
End DoDot:1
TO1 LOCK +^ACRPO(1):2
+1 IF $TEST=1
Begin DoDot:1
+2 SET ACRNUM=$PIECE(^ACRPO(1,20,ACRFY,0),U,2)
+3 SET ACRNUM=ACRNUM+1
+4 SET $PIECE(^ACRPO(1,20,ACRFY,0),U,2)=ACRNUM
+5 SET ACRAPT=$PIECE(^ACRPO(1,0),U,4)
+6 SET ACRAREA=$PIECE(^ACRPO(1,0),U,10)
+7 LOCK -^ACRPO(1):0
End DoDot:1
IF 1
+8 IF '$TEST
GOTO TO1
+9 FOR ACRJI=1:1:(4-$LENGTH(ACRNUM))
SET ACRNUM="0"_ACRNUM
+10 SET (ACRDOC,ACRNUM)=$EXTRACT(ACRFYX,4)_$EXTRACT($PIECE(^AUTTLCOD(ACRLC,0),U),1,3)_"TO"_ACRNUM
+11 IF $DATA(^ACRDOC("B",ACRNUM))
GOTO TO1
+12 KILL ACRFYX
+13 QUIT
DOCAMEND LOCK +^ACRDOC(ACRAMEND,0):2
+1 IF '$TEST
GOTO DOCAMEND
+2 SET X=$PIECE(^ACRDOC(ACRAMEND,0),U,9)
+3 SET X=X+1
+4 SET $PIECE(^ACRDOC(ACRAMEND,0),U,9)=X
+5 LOCK -^ACRDOC(ACRAMEND,0):0
+6 FOR Y=1:1:3-$LENGTH(X)
SET X="0"_X
+7 NEW ACRREFDA,ACRREF
+8 SET ACRDOC=$PIECE(^ACRDOC(ACRAMEND,0),U)_X
+9 SET ACRANUM=X
+10 SET ACRDOC2=$PIECE(^ACRDOC(ACRAMEND,0),U,2)
+11 SET ACRREFDA=$PIECE(^ACRDOC(ACRAMEND,0),U,13)
+12 SET ACRREF=$PIECE(^AUTTDOCR(ACRREFDA,0),U)
+13 QUIT
