ACRFNEW1 ;IHS/OIRM/DSD/THL,AEF - CREATE NEW DOCUMENT - UTILITY; [ 10/27/2004 4:15 PM ]
;;2.1;ADMIN RESOURCE MGT SYSTEM;**14**;NOV 05, 2001
;;UTILITY ROUTINE TO CREATE NEW DOCUMENTS
;CALLNUM ;EP;CALCULATE CALL NUMBER ;OLD CODE ACR*2.1*14.03 IM13538
;N ACRTCALL
;L +^ACRDOC(ACRBPA,0):4
;S ACRCALL=$P(^ACRDOC(ACRBPA,0),U,20)
;D NUM
;I ACRCALL>ACRTCALL S ACRTCALL=ACRCALL
;I ACRTCALL<100 S ACRCALL=ACRTCALL+1
;E I ACRTCALL>99,ACRCALL'?1U1N&(ACRCALL'?2U) S ACRCALL="A1"
;E I $E(ACRCALL)?1U D C1
C ;S $P(^ACRDOC(ACRBPA,0),U,20)=ACRCALL
;L -^ACRDOC(ACRBPA,0):0
;Q
;C1 I ACRCALL="ZZ" S ACRCALL="A0" Q ;OLD CODE ACR*2.1*14.03 IM13538
;N X1,X2
;S X1=$E(ACRCALL)
;S X2=$E(ACRCALL,2)
;I X2?1N,X2<9 S X2=X2+1
;E I X2=9 S X2="A"
;E I $A(X2)<90 S X2=$C($S($A(X2)>64:$A(X2),1:64)+1)
;E S X2=0
;I X2=0 S X1=$C($A(X1)+1)
;S ACRCALL=X1_X2
;Q
;NUM ;CALCULATE NUMBER OF CALLS TO DATE ;OLD CODE ACR*2.1*14.03 IM13538
;N I
;S (I,ACRTCALL)=0
;F S I=$O(^ACRDOC("BPA",ACRBPA,I)) Q:'I S ACRTCALL=ACRTCALL+1
;Q
CALLNUM(ACRBPA) ;EP; EXTRINSIC FUNCTION TO CALCULATE CALL NUMBER ACR*2.1*14.03 IM13538
; Enter with FMS Document ien for BPA
; Returns next extension for call number
;
N ACRTCALL
S ACRCALL=""
L +^ACRDOC(ACRBPA,0):4 I '$T Q ACRCALL
S ACRCALL=$P(^ACRDOC(ACRBPA,0),U,20) ;LAST CALL NUMBER
S ACRTCALL=$$NUM^ACRFNEW1(ACRBPA) ;NEXT CALL NUMBER
S $P(^ACRDOC(ACRBPA,0),U,20)=$$C1(ACRTCALL,.ACRCALL)
L -^ACRDOC(ACRBPA,0):0
Q ACRCALL
;
C1(ACRTCALL,ACRCALL) ; LOCAL ENTRY; EXTRINSIC FUNCTION TO CALCULATE BPA EXTENSION; ACR*2.1*14.03 IM13538
; --------ENTERS
; ACRTCALL=NEXT CALL NUMBER
; ACRCALL= LAST CALL NUMBER
;
; RETURNS:
; ACRCALL = CALL NUMBER TO USE
;
I ACRCALL>ACRTCALL S ACRTCALL=ACRCALL
I ACRTCALL<98,$E(ACRCALL)'?1U S ACRCALL=ACRTCALL+1 Q ACRCALL ; NUMBER
I ACRTCALL>98,$E(ACRCALL)'?1U S ACRCALL="A1" Q ACRCALL
N X1,X2
S X1=$E(ACRCALL)
S X2=$E(ACRCALL,2)
D
.I X2?1N,X2<9 S X2=X2+1 Q
.I X2=9 S X2="A" Q
.I $A(X2)<90 S X2=$C($S($A(X2)>64:$A(X2),1:64)+1) Q
.S X2=0 Q
I X2=0 S X1=$C($A(X1)+1)
S ACRCALL=X1_X2
Q ACRCALL
;
NUM(ACRBPA) ;LOCAL ENTRY; EXTRINSIC FUNCTION TO CALCULATE NUMBER OF CALLS TO DATE; ACR*2.1*14.03 IM13538
; RETURNS NUMBER OF CALL DOCUMENTS IN BPA CROSS-REFERENCE
N I
S (I,ACRTCALL)=0
F S I=$O(^ACRDOC("BPA",ACRBPA,I)) Q:'I S ACRTCALL=ACRTCALL+1
Q ACRTCALL ; ACR*2.1*14.03 IM13538
;
LASTBPA(X) ;EP
;----- EXTRINSIC FUNCTION - DETERMINES IF ALL BPA CALL NUMBERS HAVE
; BEEN USED
;
; INPUT:
; X = DOCUMENT INTERNAL ENTRY NUMBER
;
; RETURNS:
; 1 IF ALL NUMBERS HAVE BEEN USED
; 0 IF ALL NUMBERS HAVE NOT BEEN USED
;
N Z
S Z=$P(^ACRDOC(X,0),U,2)
I Z']"" Q 1
S Z=$E(Z,1,8)_"ZZ"
I $D(^ACRDOC("C",Z)) Q 1
Q 0
;
AMEND(Y) ;EP; ; ACR*2.1*14.02 IM13539
; - DETERMINES IF DOCUMENT HAS ALREADY BEEN AMENDED
; - AND DISALLOWS THE AMENDING OF AMENDMENTS
;
; INPUT:
; Y = DOCUMENT INTERNAL ENTRY NUMBER
;
; RETURNS:
; 1 IF NOT AN AMENDED DOCUMENT
; 0 IF ALREADY AN AMENDED DOCUMENT
;
N ACRDOC,ACRDOC0,ACRAPV,ACRREF
S ACRDOC0=^ACRDOC(+Y,0)
I $P(ACRDOC0,U,15) Q 0 ; Doc Amended field
S ACRDOC=$P(ACRDOC0,U,1)
I ACRDOC["-",$L($P(ACRDOC,"-",4))>4 Q 0 ; Amended request
I $L($P(ACRDOC0,U,2))>10 Q 0 ; Amended PO
S ACRAPV=$G(^ACROBL(+Y,"APV")) ; Doc is approved
I $P(ACRAPV,U)="A" Q 1
Q 0
ACRFNEW1 ;IHS/OIRM/DSD/THL,AEF - CREATE NEW DOCUMENT - UTILITY; [ 10/27/2004 4:15 PM ]
+1 ;;2.1;ADMIN RESOURCE MGT SYSTEM;**14**;NOV 05, 2001
+2 ;;UTILITY ROUTINE TO CREATE NEW DOCUMENTS
+3 ;CALLNUM ;EP;CALCULATE CALL NUMBER ;OLD CODE ACR*2.1*14.03 IM13538
+4 ;N ACRTCALL
+5 ;L +^ACRDOC(ACRBPA,0):4
+6 ;S ACRCALL=$P(^ACRDOC(ACRBPA,0),U,20)
+7 ;D NUM
+8 ;I ACRCALL>ACRTCALL S ACRTCALL=ACRCALL
+9 ;I ACRTCALL<100 S ACRCALL=ACRTCALL+1
+10 ;E I ACRTCALL>99,ACRCALL'?1U1N&(ACRCALL'?2U) S ACRCALL="A1"
+11 ;E I $E(ACRCALL)?1U D C1
C ;S $P(^ACRDOC(ACRBPA,0),U,20)=ACRCALL
+1 ;L -^ACRDOC(ACRBPA,0):0
+2 ;Q
+3 ;C1 I ACRCALL="ZZ" S ACRCALL="A0" Q ;OLD CODE ACR*2.1*14.03 IM13538
+4 ;N X1,X2
+5 ;S X1=$E(ACRCALL)
+6 ;S X2=$E(ACRCALL,2)
+7 ;I X2?1N,X2<9 S X2=X2+1
+8 ;E I X2=9 S X2="A"
+9 ;E I $A(X2)<90 S X2=$C($S($A(X2)>64:$A(X2),1:64)+1)
+10 ;E S X2=0
+11 ;I X2=0 S X1=$C($A(X1)+1)
+12 ;S ACRCALL=X1_X2
+13 ;Q
+14 ;NUM ;CALCULATE NUMBER OF CALLS TO DATE ;OLD CODE ACR*2.1*14.03 IM13538
+15 ;N I
+16 ;S (I,ACRTCALL)=0
+17 ;F S I=$O(^ACRDOC("BPA",ACRBPA,I)) Q:'I S ACRTCALL=ACRTCALL+1
+18 ;Q
CALLNUM(ACRBPA) ;EP; EXTRINSIC FUNCTION TO CALCULATE CALL NUMBER ACR*2.1*14.03 IM13538
+1 ; Enter with FMS Document ien for BPA
+2 ; Returns next extension for call number
+3 ;
+4 NEW ACRTCALL
+5 SET ACRCALL=""
+6 LOCK +^ACRDOC(ACRBPA,0):4
IF '$TEST
QUIT ACRCALL
+7 ;LAST CALL NUMBER
SET ACRCALL=$PIECE(^ACRDOC(ACRBPA,0),U,20)
+8 ;NEXT CALL NUMBER
SET ACRTCALL=$$NUM^ACRFNEW1(ACRBPA)
+9 SET $PIECE(^ACRDOC(ACRBPA,0),U,20)=$$C1(ACRTCALL,.ACRCALL)
+10 LOCK -^ACRDOC(ACRBPA,0):0
+11 QUIT ACRCALL
+12 ;
C1(ACRTCALL,ACRCALL) ; LOCAL ENTRY; EXTRINSIC FUNCTION TO CALCULATE BPA EXTENSION; ACR*2.1*14.03 IM13538
+1 ; --------ENTERS
+2 ; ACRTCALL=NEXT CALL NUMBER
+3 ; ACRCALL= LAST CALL NUMBER
+4 ;
+5 ; RETURNS:
+6 ; ACRCALL = CALL NUMBER TO USE
+7 ;
+8 IF ACRCALL>ACRTCALL
SET ACRTCALL=ACRCALL
+9 ; NUMBER
IF ACRTCALL<98
IF $EXTRACT(ACRCALL)'?1U
SET ACRCALL=ACRTCALL+1
QUIT ACRCALL
+10 IF ACRTCALL>98
IF $EXTRACT(ACRCALL)'?1U
SET ACRCALL="A1"
QUIT ACRCALL
+11 NEW X1,X2
+12 SET X1=$EXTRACT(ACRCALL)
+13 SET X2=$EXTRACT(ACRCALL,2)
+14 Begin DoDot:1
+15 IF X2?1N
IF X2<9
SET X2=X2+1
QUIT
+16 IF X2=9
SET X2="A"
QUIT
+17 IF $ASCII(X2)<90
SET X2=$CHAR($SELECT($ASCII(X2)>64:$ASCII(X2),1:64)+1)
QUIT
+18 SET X2=0
QUIT
End DoDot:1
+19 IF X2=0
SET X1=$CHAR($ASCII(X1)+1)
+20 SET ACRCALL=X1_X2
+21 QUIT ACRCALL
+22 ;
NUM(ACRBPA) ;LOCAL ENTRY; EXTRINSIC FUNCTION TO CALCULATE NUMBER OF CALLS TO DATE; ACR*2.1*14.03 IM13538
+1 ; RETURNS NUMBER OF CALL DOCUMENTS IN BPA CROSS-REFERENCE
+2 NEW I
+3 SET (I,ACRTCALL)=0
+4 FOR
SET I=$ORDER(^ACRDOC("BPA",ACRBPA,I))
IF 'I
QUIT
SET ACRTCALL=ACRTCALL+1
+5 ; ACR*2.1*14.03 IM13538
QUIT ACRTCALL
+6 ;
LASTBPA(X) ;EP
+1 ;----- EXTRINSIC FUNCTION - DETERMINES IF ALL BPA CALL NUMBERS HAVE
+2 ; BEEN USED
+3 ;
+4 ; INPUT:
+5 ; X = DOCUMENT INTERNAL ENTRY NUMBER
+6 ;
+7 ; RETURNS:
+8 ; 1 IF ALL NUMBERS HAVE BEEN USED
+9 ; 0 IF ALL NUMBERS HAVE NOT BEEN USED
+10 ;
+11 NEW Z
+12 SET Z=$PIECE(^ACRDOC(X,0),U,2)
+13 IF Z']""
QUIT 1
+14 SET Z=$EXTRACT(Z,1,8)_"ZZ"
+15 IF $DATA(^ACRDOC("C",Z))
QUIT 1
+16 QUIT 0
+17 ;
AMEND(Y) ;EP; ; ACR*2.1*14.02 IM13539
+1 ; - DETERMINES IF DOCUMENT HAS ALREADY BEEN AMENDED
+2 ; - AND DISALLOWS THE AMENDING OF AMENDMENTS
+3 ;
+4 ; INPUT:
+5 ; Y = DOCUMENT INTERNAL ENTRY NUMBER
+6 ;
+7 ; RETURNS:
+8 ; 1 IF NOT AN AMENDED DOCUMENT
+9 ; 0 IF ALREADY AN AMENDED DOCUMENT
+10 ;
+11 NEW ACRDOC,ACRDOC0,ACRAPV,ACRREF
+12 SET ACRDOC0=^ACRDOC(+Y,0)
+13 ; Doc Amended field
IF $PIECE(ACRDOC0,U,15)
QUIT 0
+14 SET ACRDOC=$PIECE(ACRDOC0,U,1)
+15 ; Amended request
IF ACRDOC["-"
IF $LENGTH($PIECE(ACRDOC,"-",4))>4
QUIT 0
+16 ; Amended PO
IF $LENGTH($PIECE(ACRDOC0,U,2))>10
QUIT 0
+17 ; Doc is approved
SET ACRAPV=$GET(^ACROBL(+Y,"APV"))
+18 IF $PIECE(ACRAPV,U)="A"
QUIT 1
+19 QUIT 0
