- 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 Feb 18, 2025@23:30:37 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
