- PRCFDLN ;WISC@ALTOONA/CTB-CREATE NEXT DOCUMENT LOCATOR NUMBER ;27 Feb 90/11:39 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;CREATE DOCUMENT LOCATOR NUMBER FOR CERTIFIED INVOICE
- ;REQUIRES PRCFX("X")=DATE,PRC("SITE")=STATION NUMBER
- ;IF PRCFX("X") IS UNDEFINED, OR NOT ?7N PROGRAM WILL ASSUME CURRENT DATE
- I $S($D(PRC("SITE"))["0":1,+PRC("SITE")=0:1,1:0) S X=" Station Number is undefined, Processing is terminated.*" D MSG^PRCFQ S %=0 Q
- I $S($D(PRCFX("X"))[0:1,PRCFX("X")?7N:1,1:0) D NOW^PRCFQ S PRCFX("X")=X S:$D(DT)[0 DT=X K %,%X,X,Y
- S X=PRCFX("X") D JD S PRCFDLN=Y,X=PRC("SITE")_"-DLN-"_X D DLN
- S PRCFDLN=PRCFDLN_"7"_PRC("SITE")_Y K Y,%Y,DA Q
- JD ;CREATE JULIAN DATE FROM FM INTERNAL DATE
- ;REQUIRES X=FM INTERNAL DATE. RETURN Y AS JULIAN DAY NUMBER
- N DAY,DAYS,MO,YR,I,Z
- S Y=-1,DAYS="31^28^31^30^31^30^31^31^30^31^30^31"
- S YR=$E(X,1,3)+1700,MO=+$E(X,4,5),DAY=+$E(X,6,7)
- I (YR#4=0)&((YR#100)!(YR#400=0)) S $P(DAYS,"^",2)=29
- S Z=0 F I=1:1:MO-1 Q:MO=I S Z=Z+$P(DAYS,"^",I)
- S Y=Z+DAY,Y="000"_Y,Y=$E(Y,$L(Y)-2,$L(Y)),Y=Y_$E(YR,4) Q
- DLN ;GET NEXT SEQUENCE NUMBER FOR JULIAN DATE
- ;REQUIRES X=PRC("SITE")_"-"_JULIAN DATE. JD must be in fromat dddy where ddd is Julian day and y is last character of year.
- ;returns next julian date for the number in Y where Y=+Y
- D NEXT Q:Y<0
- S Y="000"_Y,Y=$E(Y,$L(Y)-2,$L(Y)),%=1 Q
- NEXT N PRCFX,K S K=0,Y=$O(^PRCF(421.7,"B",X,0))
- I Y="" S DIC=421.7,DIC(0)="XL",DLAYGO=DIC D ^DIC S %=0 K DIC,DLAYGO Q:Y<0
- L +^PRCF(421.7):5 I '$T S X="Document Locator Number file unavailable - File lock timeout.*" D MSG^PRCFQ Q
- S Y(0)=^PRCF(421.7,+Y,0),Y1=$P(Y(0),"^",2)+1,$P(^(0),"^",2,3)=Y1_"^"_DT,Y=Y1 L -^PRCF(421.7):0 K Y(0),Y1,X Q
- MSG S PRCFX=$S($D(X)'[0:X,1:""),X="Please hold on while I find the next available number.*" D MSG^PRCFQ S X=PRCFX Q
- Q
- X S %DT="AET" D ^%DT S X=Y D JD G X
- DIS N I F I=1:1:8 W !,$P($T(DISP+I),";",3,99)
- I $D(PRC("SITE")) S %A="Do you want me to get you the NEXT DLN",%B="A 'Yes' will display the next number, a 'No' or '^' will not.",%=1 D ^PRCFYN I %=1 D V W !,"The Next DLN is: ",PRCFDLN K PRCFDLN
- Q
- DISP ;;
- ;;The Document Locator Number (DLN) is an eleven (11) position number
- ;;composed of the following fields:
- ;;
- ;;Julian Day Number - 3 numbers
- ;;Year - 1 number (last digit of calendar year)
- ;;Data Origin Code - 1 number (ALWAYS a '7' for IFCAP)
- ;;Station Number - 3 numbers
- ;;Sequence Number - 3 numbers (Starts at one (001) every day)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDLN 2556 printed Feb 18, 2025@23:29:26 Page 2
- PRCFDLN ;WISC@ALTOONA/CTB-CREATE NEXT DOCUMENT LOCATOR NUMBER ;27 Feb 90/11:39 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;CREATE DOCUMENT LOCATOR NUMBER FOR CERTIFIED INVOICE
- +3 ;REQUIRES PRCFX("X")=DATE,PRC("SITE")=STATION NUMBER
- +4 ;IF PRCFX("X") IS UNDEFINED, OR NOT ?7N PROGRAM WILL ASSUME CURRENT DATE
- +5 IF $SELECT($DATA(PRC("SITE"))["0":1,+PRC("SITE")=0:1,1:0)
- SET X=" Station Number is undefined, Processing is terminated.*"
- DO MSG^PRCFQ
- SET %=0
- QUIT
- +6 IF $SELECT($DATA(PRCFX("X"))[0:1,PRCFX("X")?7N:1,1:0)
- DO NOW^PRCFQ
- SET PRCFX("X")=X
- if $DATA(DT)[0
- SET DT=X
- KILL %,%X,X,Y
- +7 SET X=PRCFX("X")
- DO JD
- SET PRCFDLN=Y
- SET X=PRC("SITE")_"-DLN-"_X
- DO DLN
- +8 SET PRCFDLN=PRCFDLN_"7"_PRC("SITE")_Y
- KILL Y,%Y,DA
- QUIT
- JD ;CREATE JULIAN DATE FROM FM INTERNAL DATE
- +1 ;REQUIRES X=FM INTERNAL DATE. RETURN Y AS JULIAN DAY NUMBER
- +2 NEW DAY,DAYS,MO,YR,I,Z
- +3 SET Y=-1
- SET DAYS="31^28^31^30^31^30^31^31^30^31^30^31"
- +4 SET YR=$EXTRACT(X,1,3)+1700
- SET MO=+$EXTRACT(X,4,5)
- SET DAY=+$EXTRACT(X,6,7)
- +5 IF (YR#4=0)&((YR#100)!(YR#400=0))
- SET $PIECE(DAYS,"^",2)=29
- +6 SET Z=0
- FOR I=1:1:MO-1
- if MO=I
- QUIT
- SET Z=Z+$PIECE(DAYS,"^",I)
- +7 SET Y=Z+DAY
- SET Y="000"_Y
- SET Y=$EXTRACT(Y,$LENGTH(Y)-2,$LENGTH(Y))
- SET Y=Y_$EXTRACT(YR,4)
- QUIT
- DLN ;GET NEXT SEQUENCE NUMBER FOR JULIAN DATE
- +1 ;REQUIRES X=PRC("SITE")_"-"_JULIAN DATE. JD must be in fromat dddy where ddd is Julian day and y is last character of year.
- +2 ;returns next julian date for the number in Y where Y=+Y
- +3 DO NEXT
- if Y<0
- QUIT
- +4 SET Y="000"_Y
- SET Y=$EXTRACT(Y,$LENGTH(Y)-2,$LENGTH(Y))
- SET %=1
- QUIT
- NEXT NEW PRCFX,K
- SET K=0
- SET Y=$ORDER(^PRCF(421.7,"B",X,0))
- +1 IF Y=""
- SET DIC=421.7
- SET DIC(0)="XL"
- SET DLAYGO=DIC
- DO ^DIC
- SET %=0
- KILL DIC,DLAYGO
- if Y<0
- QUIT
- +2 LOCK +^PRCF(421.7):5
- IF '$TEST
- SET X="Document Locator Number file unavailable - File lock timeout.*"
- DO MSG^PRCFQ
- QUIT
- +3 SET Y(0)=^PRCF(421.7,+Y,0)
- SET Y1=$PIECE(Y(0),"^",2)+1
- SET $PIECE(^(0),"^",2,3)=Y1_"^"_DT
- SET Y=Y1
- LOCK -^PRCF(421.7):0
- KILL Y(0),Y1,X
- QUIT
- MSG SET PRCFX=$SELECT($DATA(X)'[0:X,1:"")
- SET X="Please hold on while I find the next available number.*"
- DO MSG^PRCFQ
- SET X=PRCFX
- QUIT
- +1 QUIT
- X SET %DT="AET"
- DO ^%DT
- SET X=Y
- DO JD
- GOTO X
- DIS NEW I
- FOR I=1:1:8
- WRITE !,$PIECE($TEXT(DISP+I),";",3,99)
- +1 IF $DATA(PRC("SITE"))
- SET %A="Do you want me to get you the NEXT DLN"
- SET %B="A 'Yes' will display the next number, a 'No' or '^' will not."
- SET %=1
- DO ^PRCFYN
- IF %=1
- DO V
- WRITE !,"The Next DLN is: ",PRCFDLN
- KILL PRCFDLN
- +2 QUIT
- DISP ;;
- +1 ;;The Document Locator Number (DLN) is an eleven (11) position number
- +2 ;;composed of the following fields:
- +3 ;;
- +4 ;;Julian Day Number - 3 numbers
- +5 ;;Year - 1 number (last digit of calendar year)
- +6 ;;Data Origin Code - 1 number (ALWAYS a '7' for IFCAP)
- +7 ;;Station Number - 3 numbers
- +8 ;;Sequence Number - 3 numbers (Starts at one (001) every day)