ACRFNEW1.m

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