LRAIRNUM.m

LRAIRNUM ; IHS/DIR/FJE - DoD SPECFIC ROUTINE FIND INPATIENT REGISTER NUMBER GEM/LL 12/9/86 2:24 PM ;

 ;;5.2;LR;**1013**;JUL 15, 2002

 ;

 ;;5.2;LAB SERVICE;;Sep 27, 1994

 ; This routine is only used in DoD sites  Resave as IAARNUM and remove the STOP line.

STOP Q

GO S IARNO="",IAI=$O(^DPT(IADA,"DA","AA",(9999999-IAX)\1)) I IAI>0 S IAI=$O(^(IAI,0))

 I IAI>0,$D(^DPT(IADA,"DA",IAI,0)),+^(0)'>IAX S IARNO=$S('$D(^(1)):$S($D(^(9000)):+^(9000),1:""),+^(1)>IAX:$S($D(^(9000)):+^(9000),1:""),1:"")

 S IARNO=$S($D(^DIC(9008,+IARNO,0)):$P(^(0),"^",1),1:"") K IAI Q

LRAIRNUM  ; IHS/DIR/FJE - DoD SPECFIC ROUTINE FIND INPATIENT REGISTER NUMBER GEM/LL 12/9/86 2:24 PM ;

 +1       ;;5.2;LR;**1013**;JUL 15, 2002

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4       ; This routine is only used in DoD sites  Resave as IAARNUM and remove the STOP line.

STOP       QUIT 

GO         SET IARNO=""

           SET IAI=$ORDER(^DPT(IADA,"DA","AA",(9999999-IAX)\1))

           IF IAI>0

               SET IAI=$ORDER(^(IAI,0))

 +1        IF IAI>0

               IF $DATA(^DPT(IADA,"DA",IAI,0))

                   IF +^(0)'>IAX

                       SET IARNO=$SELECT('$DATA(^(1)):$SELECT($DATA(^(9000)):+^(9000),1:""),+^(1)>IAX:$SELECT($DATA(^(9000)):+^(9000),1:""),1:"")

 +2        SET IARNO=$SELECT($DATA(^DIC(9008,+IARNO,0)):$PIECE(^(0),"^",1),1:"")

           KILL IAI

           QUIT