source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFPAR.m@ 1582

Last change on this file since 1582 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1PRCFPAR ;WISC/LEM-PARTIAL NUMBER UTILITY ;9/20/94 10:05
2V ;;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
7NEXT . ; 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
22HEAD W !?15,"IFCAP Partial Number Conversion Table",!!
23 Q
24 ;
25ALPHA(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 ;
39NUM(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
Note: See TracBrowser for help on using the repository browser.