BLRMERGU.m

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