ACHSLDCR.m

ACHSLDCR ; IHS/ITSC/PMF - LOCATE DCR FROM CHS SERVICE CLASS DICTIONARY ;   [ 10/16/2001   8:16 AM ]

 ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 ;

 I +ACHSDCR>0 G END

 S ACHSDCR=-1

 I '$D(ACHSCC) W !,"DCR LOOKUP ERROR :   No Cost Center.",!! W:$$DIR^XBDIR("E") "" G END

 S N=$O(^ACHS(3,DUZ(2),1,ACHSSCC,"CC","B",ACHSCC,"")),ACHSDCR=""

 G END:+N<1

 I $D(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0)) S ACHSDCR=$P($G(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0)),U,2),ACHS("DCRS")=$G(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0))

 S ACHS=0

 F I=2:1 Q:+$P(ACHS("DCRS"),U,I)=0  S ACHS=ACHS+1

 G END:ACHS<2

 F I=1:1:ACHS W !?5,I,?10,$P(^ACHS(9,DUZ(2),"RN"),U,+$P(ACHS("DCRS"),U,I+1))

 S Y=$$DIR^XBDIR("N^1:"_ACHS,"     SELECT DCR ACCOUNT","","","","",2)

 I $D(DUOUT)!$D(DTOUT) S ACHSDCR=-1 G END

 S ACHSDCR=$P(ACHS("DCRS"),U,Y+1)

END ;

 K ACHS("DCRS")

 I +ACHSDCR>0 W "(",$P(^ACHS(9,DUZ(2),"RN"),U,+ACHSDCR),")"

 Q

 ;

ACHSLDCR  ; IHS/ITSC/PMF - LOCATE DCR FROM CHS SERVICE CLASS DICTIONARY ;   [ 10/16/2001   8:16 AM ]

 +1       ;;3.1;CONTRACT HEALTH MGMT SYSTEM;;JUN 11, 2001

 +2       ;

 +3        IF +ACHSDCR>0

               GOTO END

 +4        SET ACHSDCR=-1

 +5        IF '$DATA(ACHSCC)

               WRITE !,"DCR LOOKUP ERROR :   No Cost Center.",!!

               IF $$DIR^XBDIR("E")

                   WRITE ""

               GOTO END

 +6        SET N=$ORDER(^ACHS(3,DUZ(2),1,ACHSSCC,"CC","B",ACHSCC,""))

           SET ACHSDCR=""

 +7        IF +N<1

               GOTO END

 +8        IF $DATA(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0))

               SET ACHSDCR=$PIECE($GET(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0)),U,2)

               SET ACHS("DCRS")=$GET(^ACHS(3,DUZ(2),1,ACHSSCC,"CC",N,0))

 +9        SET ACHS=0

 +10       FOR I=2:1

               IF +$PIECE(ACHS("DCRS"),U,I)=0

                   QUIT 

               SET ACHS=ACHS+1

 +11       IF ACHS<2

               GOTO END

 +12       FOR I=1:1:ACHS

               WRITE !?5,I,?10,$PIECE(^ACHS(9,DUZ(2),"RN"),U,+$PIECE(ACHS("DCRS"),U,I+1))

 +13       SET Y=$$DIR^XBDIR("N^1:"_ACHS,"     SELECT DCR ACCOUNT","","","","",2)

 +14       IF $DATA(DUOUT)!$DATA(DTOUT)

               SET ACHSDCR=-1

               GOTO END

 +15       SET ACHSDCR=$PIECE(ACHS("DCRS"),U,Y+1)

END       ;

 +1        KILL ACHS("DCRS")

 +2        IF +ACHSDCR>0

               WRITE "(",$PIECE(^ACHS(9,DUZ(2),"RN"),U,+ACHSDCR),")"

 +3        QUIT 

 +4       ;