| [613] | 1 | PRCFPAR ;WISC/LEM-PARTIAL NUMBER UTILITY ;9/20/94 10:05
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | N N1 S N1=$G(^PRCF(421.5,PRCF("CIDA"),1))
|
|---|
| 5 | S PRCF("PO")=$P(N1,U,3),PRCF("PA")=$P(N1,U,6)
|
|---|
| 6 | I PRCF("PA")'?1N.UN D
|
|---|
| 7 | NEXT . ; Obtain next available Partial# for the PO
|
|---|
| 8 | . N K S K=0,Y=$O(^PRCF(421.9,"B",PRCF("PO"),0))
|
|---|
| 9 | . I Y="" S X=PRCF("PO"),DIC="^PRCF(421.9,",DLAYGO=421.9,DIC(0)="XL"
|
|---|
| 10 | . I Y="" K DO,DINUM,DIC("DR") D FILE^DICN S %=0 K DIC,DLAYGO Q:Y<0
|
|---|
| 11 | . L +^PRCF(421.9):5 I '$T W !,"Partial Number File unavailable." Q
|
|---|
| 12 | . S Y(0)=^PRCF(421.9,+Y,0),Y1=$P(Y(0),"^",2)+1
|
|---|
| 13 | . S $P(^PRCF(421.9,+Y,0),"^",2)=Y1,PRCF("PA")=Y1
|
|---|
| 14 | . L -^PRCF(421.9) K Y(0),Y1,X
|
|---|
| 15 | . S $P(^PRCF(421.5,PRCF("CIDA"),1),U,6)=PRCF("PA")
|
|---|
| 16 | . Q
|
|---|
| 17 | ;
|
|---|
| 18 | N XPO S PRCF("PA")="00"_PRCF("PA")
|
|---|
| 19 | S PRCF("PA")=$E(PRCF("PA"),$L(PRCF("PA"))-1,$L(PRCF("PA")))
|
|---|
| 20 | S XPO=$P(PRCF("PO"),"-",1)_$P(PRCF("PO"),"-",2)_PRCF("PA")
|
|---|
| 21 | Q
|
|---|
| 22 | HEAD W !?15,"IFCAP Partial Number Conversion Table",!!
|
|---|
| 23 | Q
|
|---|
| 24 | ;
|
|---|
| 25 | ALPHA(NUM,ALPHA) ; Generate two-character alphanumeric Partial #
|
|---|
| 26 | ; from three-character numeric
|
|---|
| 27 | N C,I,P
|
|---|
| 28 | I NUM'?1N.N S ALPHA=-1 Q
|
|---|
| 29 | I NUM<1!(NUM>974) S ALPHA=-1 Q
|
|---|
| 30 | I NUM?1N S ALPHA="0"_NUM Q
|
|---|
| 31 | I NUM?2N S ALPHA=NUM Q
|
|---|
| 32 | I NUM?3N D
|
|---|
| 33 | . S P(1)=NUM-100\35+1,P(2)=NUM-100#35+1
|
|---|
| 34 | . F I=1,2 S C(I)=$E("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",P(I))
|
|---|
| 35 | . S ALPHA=C(1)_C(2) ;W:'(NUM-2#7*10) ! W ?(NUM-2#7*10),NUM,"=",ALPHA
|
|---|
| 36 | . Q
|
|---|
| 37 | Q
|
|---|
| 38 | ;
|
|---|
| 39 | NUM(ALPHA,NUM) ; Generate IFCAP partial # from FMS partial #.
|
|---|
| 40 | S ALPHA=$TR(ALPHA,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") S NUM=ALPHA
|
|---|
| 41 | I ALPHA["O"!(ALPHA=0)!(ALPHA="00") S NUM=-1 Q
|
|---|
| 42 | I '(ALPHA?1N!(ALPHA?2UN)) S NUM=-1 Q
|
|---|
| 43 | I ALPHA?1N!(ALPHA?2N) S NUM=+ALPHA Q
|
|---|
| 44 | F I=1,2 S C(I)=$E(ALPHA,I),P(I)=$F("ABCDEFGHIJKLMNPQRSTUVWXYZ0123456789",C(I))
|
|---|
| 45 | I 'P(1)!'P(2) S NUM=-1 Q
|
|---|
| 46 | S NUM=98+(P(1)-2*35)+P(2) W !,NUM
|
|---|
| 47 | Q
|
|---|
