- BLRMERGU ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - COMMON FUNCTIONS [ 12/21/1998 3:56 PM ]
- ;;5.2;BLR;**1005**;DEC 14, 1998
- ;
- ; This routine contains common function used by other BLRMERG*
- ; routines.
- ;
- Q ; no entry from top
- ;
- SETVARS ;EP - SET BLRDATE, BLRDTSUB, BLRNUM, BLRAIEN, BLRACC
- ; upon entry BLROLD,BLRSUB,BLRINVDT must be set
- S (BLRDATE,BLRDTSUB,BLRNUM,BLRAIEN)=""
- ; get accession area and ien within date subscript
- I BLRSUB="AU" S BLRACC=$P(^LR(BLROLD,BLRSUB),U,6) I 1
- E S BLRACC=$P(^LR(BLROLD,BLRSUB,BLRINVDT,0),U,6) ;get accession link
- ; At this point in time I see 2 forms for BLRACC, the accession
- ; link field. One is just the ien for CY, SP, EM, and AU.
- ; The other is 'XX YYYY Z' where XX is the accession area, and Z
- ; is the ien within the date subscript.
- I BLRACC=+BLRACC D I 1 ; CY, SP, EM, AU
- . S BLRNUM=BLRACC ; accession ien by datesub
- . S BLRAIEN=$O(^LRO(68,"B",BLRSUB,0)) ; get accession area
- . Q
- E D ; CH, BB, MI etc.
- . S BLRNUM=$P(BLRACC," ",3) ; accession ien by datesub
- . S BLRAIEN=$O(^LRO(68,"B",$P(BLRACC," "),0)) ;get accession area
- . Q
- Q:'BLRAIEN ; quit if no accession area
- S BLRSTYPE=$P(^LRO(68,BLRAIEN,0),U,3) ; get daily, yearly, etc.
- Q:BLRSTYPE="" ; quit if bad data
- ; get specimen date and compute date subscript
- I BLRSUB="AU" S BLRDATE=$P(+^LR(BLROLD,BLRSUB),".") I 1
- E S BLRDATE=$P(+^LR(BLROLD,BLRSUB,BLRINVDT,0),".")
- D @("SETDS"_BLRSTYPE) ; compute date subscript
- ; compute accession number in form XX YY Z for lookup into blr tx log
- I BLRACC=+BLRACC D ; CY, SP, EM, AU
- . S X=$E(BLRDATE,2,3) ; get year
- . S BLRACC=BLRSUB_" "_X_" "_BLRACC ; set to XX YY Z
- . Q
- Q
- ;
- SETDSD ; SET DATE SUB DAILY
- S BLRDTSUB=BLRDATE
- Q
- ;
- SETDSM ; SET DATE SUB MONTHLY
- S BLRDTSUB=$E(BLRDATE,1,5)_"00"
- Q
- ;
- SETDSQ ; SET DATE SUB QUARTERLY
- S BLRDTSUB=$E(BLRDATE,1,3)_"0000"+(($E(BLRDATE,4,5)-1)\3*300+100)
- Q
- ;
- SETDSY ; SET DATE SUB YEARLY
- S BLRDTSUB=$E(BLRDATE,1,3)_"0000"
- Q
- ;
- DIE ; ^DIE CALL
- D ^DIE
- K DA,DIE,DR
- Q
- ;
- DIK ; CALL ^DIK
- D ^DIK
- K DA,DIK
- Q
- ;
- IX1 ; CALL IX1^DIK
- D IX1^DIK
- K DA,DIK
- Q
- BLRMERGU ; IHS/TUCSON/DG/ANMC/CLS/ISD/EDE - COMMON FUNCTIONS [ 12/21/1998 3:56 PM ]
- +1 ;;5.2;BLR;**1005**;DEC 14, 1998
- +2 ;
- +3 ; This routine contains common function used by other BLRMERG*
- +4 ; routines.
- +5 ;
- +6 ; no entry from top
- QUIT
- +7 ;
- SETVARS ;EP - SET BLRDATE, BLRDTSUB, BLRNUM, BLRAIEN, BLRACC
- +1 ; upon entry BLROLD,BLRSUB,BLRINVDT must be set
- +2 SET (BLRDATE,BLRDTSUB,BLRNUM,BLRAIEN)=""
- +3 ; get accession area and ien within date subscript
- +4 IF BLRSUB="AU"
- SET BLRACC=$PIECE(^LR(BLROLD,BLRSUB),U,6)
- IF 1
- +5 ;get accession link
- IF '$TEST
- SET BLRACC=$PIECE(^LR(BLROLD,BLRSUB,BLRINVDT,0),U,6)
- +6 ; At this point in time I see 2 forms for BLRACC, the accession
- +7 ; link field. One is just the ien for CY, SP, EM, and AU.
- +8 ; The other is 'XX YYYY Z' where XX is the accession area, and Z
- +9 ; is the ien within the date subscript.
- +10 ; CY, SP, EM, AU
- IF BLRACC=+BLRACC
- Begin DoDot:1
- +11 ; accession ien by datesub
- SET BLRNUM=BLRACC
- +12 ; get accession area
- SET BLRAIEN=$ORDER(^LRO(68,"B",BLRSUB,0))
- +13 QUIT
- End DoDot:1
- IF 1
- +14 ; CH, BB, MI etc.
- IF '$TEST
- Begin DoDot:1
- +15 ; accession ien by datesub
- SET BLRNUM=$PIECE(BLRACC," ",3)
- +16 ;get accession area
- SET BLRAIEN=$ORDER(^LRO(68,"B",$PIECE(BLRACC," "),0))
- +17 QUIT
- End DoDot:1
- +18 ; quit if no accession area
- IF 'BLRAIEN
- QUIT
- +19 ; get daily, yearly, etc.
- SET BLRSTYPE=$PIECE(^LRO(68,BLRAIEN,0),U,3)
- +20 ; quit if bad data
- IF BLRSTYPE=""
- QUIT
- +21 ; get specimen date and compute date subscript
- +22 IF BLRSUB="AU"
- SET BLRDATE=$PIECE(+^LR(BLROLD,BLRSUB),".")
- IF 1
- +23 IF '$TEST
- SET BLRDATE=$PIECE(+^LR(BLROLD,BLRSUB,BLRINVDT,0),".")
- +24 ; compute date subscript
- DO @("SETDS"_BLRSTYPE)
- +25 ; compute accession number in form XX YY Z for lookup into blr tx log
- +26 ; CY, SP, EM, AU
- IF BLRACC=+BLRACC
- Begin DoDot:1
- +27 ; get year
- SET X=$EXTRACT(BLRDATE,2,3)
- +28 ; set to XX YY Z
- SET BLRACC=BLRSUB_" "_X_" "_BLRACC
- +29 QUIT
- End DoDot:1
- +30 QUIT
- +31 ;
- SETDSD ; SET DATE SUB DAILY
- +1 SET BLRDTSUB=BLRDATE
- +2 QUIT
- +3 ;
- SETDSM ; SET DATE SUB MONTHLY
- +1 SET BLRDTSUB=$EXTRACT(BLRDATE,1,5)_"00"
- +2 QUIT
- +3 ;
- SETDSQ ; SET DATE SUB QUARTERLY
- +1 SET BLRDTSUB=$EXTRACT(BLRDATE,1,3)_"0000"+(($EXTRACT(BLRDATE,4,5)-1)\3*300+100)
- +2 QUIT
- +3 ;
- SETDSY ; SET DATE SUB YEARLY
- +1 SET BLRDTSUB=$EXTRACT(BLRDATE,1,3)_"0000"
- +2 QUIT
- +3 ;
- DIE ; ^DIE CALL
- +1 DO ^DIE
- +2 KILL DA,DIE,DR
- +3 QUIT
- +4 ;
- DIK ; CALL ^DIK
- +1 DO ^DIK
- +2 KILL DA,DIK
- +3 QUIT
- +4 ;
- IX1 ; CALL IX1^DIK
- +1 DO IX1^DIK
- +2 KILL DA,DIK
- +3 QUIT
