PRCFPAR ;WISC/LEM-PARTIAL NUMBER UTILITY ;9/20/94 10:05
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N N1 S N1=$G(^PRCF(421.5,PRCF("CIDA"),1))
S PRCF("PO")=$P(N1,U,3),PRCF("PA")=$P(N1,U,6)
I PRCF("PA")'?1N.UN D
NEXT . ; Obtain next available Partial# for the PO
. N K S K=0,Y=$O(^PRCF(421.9,"B",PRCF("PO"),0))
. I Y="" S X=PRCF("PO"),DIC="^PRCF(421.9,",DLAYGO=421.9,DIC(0)="XL"
. I Y="" K DO,DINUM,DIC("DR") D FILE^DICN S %=0 K DIC,DLAYGO Q:Y<0
. L +^PRCF(421.9):5 I '$T W !,"Partial Number File unavailable." Q
. S Y(0)=^PRCF(421.9,+Y,0),Y1=$P(Y(0),"^",2)+1
. S $P(^PRCF(421.9,+Y,0),"^",2)=Y1,PRCF("PA")=Y1
. L -^PRCF(421.9) K Y(0),Y1,X
. S $P(^PRCF(421.5,PRCF("CIDA"),1),U,6)=PRCF("PA")
. Q
;
N XPO S PRCF("PA")="00"_PRCF("PA")
S PRCF("PA")=$E(PRCF("PA"),$L(PRCF("PA"))-1,$L(PRCF("PA")))
S XPO=$P(PRCF("PO"),"-",1)_$P(PRCF("PO"),"-",2)_PRCF("PA")
Q
HEAD W !?15,"IFCAP Partial Number Conversion Table",!!
Q
;
ALPHA(NUM,ALPHA) ; Generate two-character alphanumeric Partial #
; from three-character numeric
N C,I,P
I NUM'?1N.N S ALPHA=-1 Q
I NUM<1!(NUM>974) S ALPHA=-1 Q
I NUM?1N S ALPHA="0"_NUM Q
I NUM?2N S ALPHA=NUM Q
I NUM?3N D
. S P(1)=NUM-100\35+1,P(2)=NUM-100#35+1
. F I=1,2 S C(I)=$E("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",P(I))
. S ALPHA=C(1)_C(2) ;W:'(NUM-2#7*10) ! W ?(NUM-2#7*10),NUM,"=",ALPHA
. Q
Q
;
NUM(ALPHA,NUM) ; Generate IFCAP partial # from FMS partial #.
S ALPHA=$TR(ALPHA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") S NUM=ALPHA
I ALPHA["O"!(ALPHA=0)!(ALPHA="00") S NUM=-1 Q
I '(ALPHA?1N!(ALPHA?2UN)) S NUM=-1 Q
I ALPHA?1N!(ALPHA?2N) S NUM=+ALPHA Q
F I=1,2 S C(I)=$E(ALPHA,I),P(I)=$F("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",C(I))
I 'P(1)!'P(2) S NUM=-1 Q
S NUM=98+(P(1)-2*35)+P(2) W !,NUM
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFPAR 1867 printed Apr 09, 2024@21:14:35 Page 2
PRCFPAR ;WISC/LEM-PARTIAL NUMBER UTILITY ;9/20/94 10:05
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW N1
SET N1=$GET(^PRCF(421.5,PRCF("CIDA"),1))
+3 SET PRCF("PO")=$PIECE(N1,U,3)
SET PRCF("PA")=$PIECE(N1,U,6)
+4 IF PRCF("PA")'?1N.UN
Begin DoDot:1
NEXT ; Obtain next available Partial# for the PO
+1 NEW K
SET K=0
SET Y=$ORDER(^PRCF(421.9,"B",PRCF("PO"),0))
+2 IF Y=""
SET X=PRCF("PO")
SET DIC="^PRCF(421.9,"
SET DLAYGO=421.9
SET DIC(0)="XL"
+3 IF Y=""
KILL DO,DINUM,DIC("DR")
DO FILE^DICN
SET %=0
KILL DIC,DLAYGO
if Y<0
QUIT
+4 LOCK +^PRCF(421.9):5
IF '$TEST
WRITE !,"Partial Number File unavailable."
QUIT
+5 SET Y(0)=^PRCF(421.9,+Y,0)
SET Y1=$PIECE(Y(0),"^",2)+1
+6 SET $PIECE(^PRCF(421.9,+Y,0),"^",2)=Y1
SET PRCF("PA")=Y1
+7 LOCK -^PRCF(421.9)
KILL Y(0),Y1,X
+8 SET $PIECE(^PRCF(421.5,PRCF("CIDA"),1),U,6)=PRCF("PA")
+9 QUIT
End DoDot:1
+10 ;
+11 NEW XPO
SET PRCF("PA")="00"_PRCF("PA")
+12 SET PRCF("PA")=$EXTRACT(PRCF("PA"),$LENGTH(PRCF("PA"))-1,$LENGTH(PRCF("PA")))
+13 SET XPO=$PIECE(PRCF("PO"),"-",1)_$PIECE(PRCF("PO"),"-",2)_PRCF("PA")
+14 QUIT
HEAD WRITE !?15,"IFCAP Partial Number Conversion Table",!!
+1 QUIT
+2 ;
ALPHA(NUM,ALPHA) ; Generate two-character alphanumeric Partial #
+1 ; from three-character numeric
+2 NEW C,I,P
+3 IF NUM'?1N.N
SET ALPHA=-1
QUIT
+4 IF NUM<1!(NUM>974)
SET ALPHA=-1
QUIT
+5 IF NUM?1N
SET ALPHA="0"_NUM
QUIT
+6 IF NUM?2N
SET ALPHA=NUM
QUIT
+7 IF NUM?3N
Begin DoDot:1
+8 SET P(1)=NUM-100\35+1
SET P(2)=NUM-100#35+1
+9 FOR I=1,2
SET C(I)=$EXTRACT("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",P(I))
+10 ;W:'(NUM-2#7*10) ! W ?(NUM-2#7*10),NUM,"=",ALPHA
SET ALPHA=C(1)_C(2)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
NUM(ALPHA,NUM) ; Generate IFCAP partial # from FMS partial #.
+1 SET ALPHA=$TRANSLATE(ALPHA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
SET NUM=ALPHA
+2 IF ALPHA["O"!(ALPHA=0)!(ALPHA="00")
SET NUM=-1
QUIT
+3 IF '(ALPHA?1N!(ALPHA?2UN))
SET NUM=-1
QUIT
+4 IF ALPHA?1N!(ALPHA?2N)
SET NUM=+ALPHA
QUIT
+5 FOR I=1,2
SET C(I)=$EXTRACT(ALPHA,I)
SET P(I)=$FIND("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",C(I))
+6 IF 'P(1)!'P(2)
SET NUM=-1
QUIT
+7 SET NUM=98+(P(1)-2*35)+P(2)
WRITE !,NUM
+8 QUIT
