- PRSACED6 ; HISC/FPT-T&A Cross-Edits ;5/9/2012 13:21
- ;;4.0;PAID;**6,45,112,132**;Sep 21, 1995;Build 13
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- CODES ; Set variables T0 and T1 with 8B code list
- ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
- ;
- S T0="AN SK WD NO AU RT CE CU UN NA NB SP DA SA SB SC OA OB OC OK DB OM RA RB RC HA HB HC HD PT PA ON VC EA EB AL SL WP NP AB RL FA FB FC FD AD AF FE TM TN TS TT TW TX",N1=60
- S T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH RS RN ND NU SR SS SD SH",N2=67
- Q
- STUB ; parse out 'stub' variables from 8b record
- S RECORD=^PRST(458,PPI,"E",DFN,5)
- S STA=$E(RECORD,2,4)
- S SSN=$E(RECORD,5,13)
- S NCODE=$E(RECORD,14,16)
- S DAYNO=$E(RECORD,17,19)
- S TL=$E(RECORD,22,24)
- S LVG=$E(RECORD,25)
- S NOR=$E(RECORD,26,27)
- S PAY=$E(RECORD,28)
- S DUT=$E(RECORD,29)
- S RECORD=$E(RECORD,33,$L(RECORD))
- S (C0,C1)="",EOR=0
- Q:RECORD=""
- TYPE ; parse out type of time from 8b record
- I EOR=1 K EOR,LOOP,MATCH,RECORD,TYPE,VALUE Q
- S TYPE=$E(RECORD,1,2)
- I TYPE="CD" S VALUE=$E(RECORD,3,$L(RECORD)) D CD S EOR=1 G TYPE
- F LOOP=3:1:$L(RECORD) Q:$E(RECORD,LOOP)?1U
- S:LOOP=$L(RECORD) EOR=1
- S VALUE=$S(EOR=1:$E(RECORD,3,LOOP),1:$E(RECORD,3,LOOP-1))
- S:EOR=0 RECORD=$E(RECORD,LOOP,$L(RECORD))
- S MATCH=0
- S Z=$F(T0,TYPE)
- I Z>2 S $P(C0,"^",(Z/3)+12)=VALUE,MATCH=1
- G:MATCH=1 TYPE
- S Z=$F(T1,TYPE)
- I Z>2 S $P(C1,"^",Z/3)=VALUE
- G TYPE
- CD ; calculate/compare cd value
- S END=$L(C0,"^"),CD=0
- F LOOP=13:1:END S CD=CD+$P(C0,"^",LOOP)
- S END=$L(C1,"^")
- F LOOP=1:1:END S CD=CD+$P(C1,"^",LOOP)
- I CD'=+VALUE W !,"THE CD VALUE DID NOT ADD UP CORRECTLY FOR ",$P($G(^PRSPC(DFN,0)),"^",1)
- K CD,END Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSACED6 1979 printed Jan 18, 2025@03:24:29 Page 2
- PRSACED6 ; HISC/FPT-T&A Cross-Edits ;5/9/2012 13:21
- +1 ;;4.0;PAID;**6,45,112,132**;Sep 21, 1995;Build 13
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- CODES ; Set variables T0 and T1 with 8B code list
- +1 ; 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67
- +2 ;
- +3 SET T0="AN SK WD NO AU RT CE CU UN NA NB SP DA SA SB SC OA OB OC OK DB OM RA RB RC HA HB HC HD PT PA ON VC EA EB AL SL WP NP AB RL FA FB FC FD AD AF FE TM TN TS TT TW TX"
- SET N1=60
- +4 SET T1="CT CO US NR NS DC TF SE SF SG OE OF OG OS TA OU RE RF RG HL HM HN HO PH PB CL VS EC ED NL DW IN TL LU LN LD TO LA ML CA PC TC CY RR SQ FF DE DF YA DG TG YD YE TB DT YH TD NT NH RS RN ND NU SR SS SD SH"
- SET N2=67
- +5 QUIT
- STUB ; parse out 'stub' variables from 8b record
- +1 SET RECORD=^PRST(458,PPI,"E",DFN,5)
- +2 SET STA=$EXTRACT(RECORD,2,4)
- +3 SET SSN=$EXTRACT(RECORD,5,13)
- +4 SET NCODE=$EXTRACT(RECORD,14,16)
- +5 SET DAYNO=$EXTRACT(RECORD,17,19)
- +6 SET TL=$EXTRACT(RECORD,22,24)
- +7 SET LVG=$EXTRACT(RECORD,25)
- +8 SET NOR=$EXTRACT(RECORD,26,27)
- +9 SET PAY=$EXTRACT(RECORD,28)
- +10 SET DUT=$EXTRACT(RECORD,29)
- +11 SET RECORD=$EXTRACT(RECORD,33,$LENGTH(RECORD))
- +12 SET (C0,C1)=""
- SET EOR=0
- +13 if RECORD=""
- QUIT
- TYPE ; parse out type of time from 8b record
- +1 IF EOR=1
- KILL EOR,LOOP,MATCH,RECORD,TYPE,VALUE
- QUIT
- +2 SET TYPE=$EXTRACT(RECORD,1,2)
- +3 IF TYPE="CD"
- SET VALUE=$EXTRACT(RECORD,3,$LENGTH(RECORD))
- DO CD
- SET EOR=1
- GOTO TYPE
- +4 FOR LOOP=3:1:$LENGTH(RECORD)
- if $EXTRACT(RECORD,LOOP)?1U
- QUIT
- +5 if LOOP=$LENGTH(RECORD)
- SET EOR=1
- +6 SET VALUE=$SELECT(EOR=1:$EXTRACT(RECORD,3,LOOP),1:$EXTRACT(RECORD,3,LOOP-1))
- +7 if EOR=0
- SET RECORD=$EXTRACT(RECORD,LOOP,$LENGTH(RECORD))
- +8 SET MATCH=0
- +9 SET Z=$FIND(T0,TYPE)
- +10 IF Z>2
- SET $PIECE(C0,"^",(Z/3)+12)=VALUE
- SET MATCH=1
- +11 if MATCH=1
- GOTO TYPE
- +12 SET Z=$FIND(T1,TYPE)
- +13 IF Z>2
- SET $PIECE(C1,"^",Z/3)=VALUE
- +14 GOTO TYPE
- CD ; calculate/compare cd value
- +1 SET END=$LENGTH(C0,"^")
- SET CD=0
- +2 FOR LOOP=13:1:END
- SET CD=CD+$PIECE(C0,"^",LOOP)
- +3 SET END=$LENGTH(C1,"^")
- +4 FOR LOOP=1:1:END
- SET CD=CD+$PIECE(C1,"^",LOOP)
- +5 IF CD'=+VALUE
- WRITE !,"THE CD VALUE DID NOT ADD UP CORRECTLY FOR ",$PIECE($GET(^PRSPC(DFN,0)),"^",1)
- +6 KILL CD,END
- QUIT