BCHRLU1.m

BCHRLU1 ; IHS/CMI/LAB - GEN RET UTIL ; 

 ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 ;IHS/CMI/LAB - patch 7 Y2K

 ;

 ;IHS/CMI/LAB - PATCH 6 9/21/98

 ;IHS/CMI/LAB - patch 9 fixes variable Y to Z

MCR ;display all current medicare data

 NEW BCHMIFN

 I '$D(^DPT(P,0)) G MCRX

 I $P(^DPT(P,0),U,19) G MCRX

 I '$D(^AUPNPAT(P,0)) G MCRX

 I '$D(^AUPNMCR(P,11)) G MCRX

 I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCRX

 S BCHMIFN=0 F  S BCHMIFN=$O(^AUPNMCR(P,11,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN  D

 .Q:$P(^AUPNMCR(P,11,BCHMIFN,0),U)>D

 .I $P(^AUPNMCR(P,11,BCHMIFN,0),U,2)]"",$P(^(0),U,2)<D Q  ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98

 .S BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUPNMCR(DFN,0),U,3)_" ["_$S($P(^(0),U,4)]"":$P(^AUTTMCS($P(^(0),U,4),0),U),1:"-")_"]"

 .;begin Y2K

 .;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 .S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_($E(Y,1,3)+1700)_"-" ;Y2000

 .I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000

 .;end Y2K

 .Q

MCRX ;

 K Y,Z

 Q

 ;

MCD ;

 NEW BCHMIFN,BCHNIFN

 I '$D(^DPT(P,0)) G MCDX

 I $P(^DPT(P,0),U,19) G MCDX

 I '$D(^AUPNPAT(P,0)) G MCDX

 I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G MCDX

 S BCHMIFN=0 F  S BCHMIFN=$O(^AUPNMCD("B",P,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN  D

 .Q:'$D(^AUPNMCD(BCHMIFN,11))

 .S BCHNIFN=0 F  S BCHNIFN=$O(^AUPNMCD(BCHMIFN,11,BCHNIFN)) Q:BCHNIFN'=+BCHNIFN  D

 ..Q:BCHNIFN>D

 ..I $P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]"",$P(^(0),U,2)<D Q

 ..S BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUPNMCD(BCHMIFN,0),U,3)_"/"_$S($P(^AUPNMCD(BCHMIFN,0),U,2)]"":$P(^AUTNINS($P(^AUPNMCD(BCHMIFN,0),U,2),0),U),1:"<>")

 ..;begin Y2K

 ..;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 ..S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))_"-" ;Y2000

 ..I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000

 ..;end Y2K

 ..Q

 .Q

 ;

MCDX ;

 Q

 ;

PI ;

 NEW BCHMIFN,BCHFLG

 I '$D(^DPT(P,0)) G PIX

 I $P(^DPT(P,0),U,19) G PIX

 I '$D(^AUPNPAT(P,0)) G PIX

 I '$D(^AUPNPRVT(P,11)) G PIX

 I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX

 S BCHMIFN=0 F  S BCHMIFN=$O(^AUPNPRVT(P,11,BCHMIFN)) Q:BCHMIFN'=+BCHMIFN  D

 .Q:$P(^AUPNPRVT(P,11,BCHMIFN,0),U)=""

 .S BCHNAME=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U) Q:BCHNAME=""

 .Q:$P(^AUTNINS(BCHNAME,0),U)["AHCCCS"

 .Q:$P(^AUPNPRVT(P,11,BCHMIFN,0),U,6)>D

 .I $P(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]"",$P(^(0),U,7)<D Q  ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98

 .S BCHPCNT=BCHPCNT+1,BCHPRNM(BCHPCNT)=$P(^AUTNINS($P(^AUPNPRVT(P,11,BCHMIFN,0),U),0),U)

 .;begin Y2K

 .;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 .S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_(1700+$E(Y,1,3))_"-" ;Y2000

 .I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_(1700+$E(Z,1,3)) ;Y2000

 .;end Y2K

 .Q

PIX ;

 Q

BCHRLU1   ; IHS/CMI/LAB - GEN RET UTIL ; 

 +1       ;;2.0;IHS RPMS CHR SYSTEM;;OCT 23, 2012;Build 27

 +2       ;IHS/CMI/LAB - patch 7 Y2K

 +3       ;

 +4       ;IHS/CMI/LAB - PATCH 6 9/21/98

 +5       ;IHS/CMI/LAB - patch 9 fixes variable Y to Z

MCR       ;display all current medicare data

 +1        NEW BCHMIFN

 +2        IF '$DATA(^DPT(P,0))

               GOTO MCRX

 +3        IF $PIECE(^DPT(P,0),U,19)

               GOTO MCRX

 +4        IF '$DATA(^AUPNPAT(P,0))

               GOTO MCRX

 +5        IF '$DATA(^AUPNMCR(P,11))

               GOTO MCRX

 +6        IF $DATA(^DPT(P,.35))

               IF $PIECE(^(.35),U)]""

                   IF $PIECE(^(.35),U)<D

                       GOTO MCRX

 +7        SET BCHMIFN=0

           FOR 

               SET BCHMIFN=$ORDER(^AUPNMCR(P,11,BCHMIFN))

               IF BCHMIFN'=+BCHMIFN

                   QUIT 

               Begin DoDot:1

 +8                IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U)>D

                       QUIT 

 +9       ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98

                   IF $PIECE(^AUPNMCR(P,11,BCHMIFN,0),U,2)]""

                       IF $PIECE(^(0),U,2)<D

                           QUIT 

 +10               SET BCHPCNT=BCHPCNT+1

                   SET BCHPRNM(BCHPCNT)=$PIECE(^AUPNMCR(DFN,0),U,3)_" ["_$SELECT($PIECE(^(0),U,4)]"":$PIECE(^AUTTMCS($PIECE(^(0),U,4),0),U),1:"-")_"]"

 +11      ;begin Y2K

 +12      ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCR(DFN,11,BCHMIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 +13      ;Y2000

                   SET BCHPCNT=BCHPCNT+1

                   SET Y=$PIECE(^AUPNMCR(DFN,11,BCHMIFN,0),U)

                   SET Z=$PIECE(^(0),U,2)

                   SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_($EXTRACT(Y,1,3)+1700)_"-"

 +14      ;Y2000

                   IF Z]""

                       SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))

 +15      ;end Y2K

 +16               QUIT 

               End DoDot:1

MCRX      ;

 +1        KILL Y,Z

 +2        QUIT 

 +3       ;

MCD       ;

 +1        NEW BCHMIFN,BCHNIFN

 +2        IF '$DATA(^DPT(P,0))

               GOTO MCDX

 +3        IF $PIECE(^DPT(P,0),U,19)

               GOTO MCDX

 +4        IF '$DATA(^AUPNPAT(P,0))

               GOTO MCDX

 +5        IF $DATA(^DPT(P,.35))

               IF $PIECE(^(.35),U)]""

                   IF $PIECE(^(.35),U)<D

                       GOTO MCDX

 +6        SET BCHMIFN=0

           FOR 

               SET BCHMIFN=$ORDER(^AUPNMCD("B",P,BCHMIFN))

               IF BCHMIFN'=+BCHMIFN

                   QUIT 

               Begin DoDot:1

 +7                IF '$DATA(^AUPNMCD(BCHMIFN,11))

                       QUIT 

 +8                SET BCHNIFN=0

                   FOR 

                       SET BCHNIFN=$ORDER(^AUPNMCD(BCHMIFN,11,BCHNIFN))

                       IF BCHNIFN'=+BCHNIFN

                           QUIT 

                       Begin DoDot:2

 +9                        IF BCHNIFN>D

                               QUIT 

 +10                       IF $PIECE(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U,2)]""

                               IF $PIECE(^(0),U,2)<D

                                   QUIT 

 +11                       SET BCHPCNT=BCHPCNT+1

                           SET BCHPRNM(BCHPCNT)=$PIECE(^AUPNMCD(BCHMIFN,0),U,3)_"/"_$SELECT($PIECE(^AUPNMCD(BCHMIFN,0),U,2)]"":$PIECE(^AUTNINS($PIECE(^AUPNMCD(BCHMIFN,0),U,2),0),U),1:"<>")

 +12      ;begin Y2K

 +13      ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U),Z=$P(^(0),U,2),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 +14      ;Y2000

                           SET BCHPCNT=BCHPCNT+1

                           SET Y=$PIECE(^AUPNMCD(BCHMIFN,11,BCHNIFN,0),U)

                           SET Z=$PIECE(^(0),U,2)

                           SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))_"-"

 +15      ;Y2000

                           IF Z]""

                               SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))

 +16      ;end Y2K

 +17                       QUIT 

                       End DoDot:2

 +18               QUIT 

               End DoDot:1

 +19      ;

MCDX      ;

 +1        QUIT 

 +2       ;

PI        ;

 +1        NEW BCHMIFN,BCHFLG

 +2        IF '$DATA(^DPT(P,0))

               GOTO PIX

 +3        IF $PIECE(^DPT(P,0),U,19)

               GOTO PIX

 +4        IF '$DATA(^AUPNPAT(P,0))

               GOTO PIX

 +5        IF '$DATA(^AUPNPRVT(P,11))

               GOTO PIX

 +6        IF $DATA(^DPT(P,.35))

               IF $PIECE(^(.35),U)]""

                   IF $PIECE(^(.35),U)<D

                       GOTO PIX

 +7        SET BCHMIFN=0

           FOR 

               SET BCHMIFN=$ORDER(^AUPNPRVT(P,11,BCHMIFN))

               IF BCHMIFN'=+BCHMIFN

                   QUIT 

               Begin DoDot:1

 +8                IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U)=""

                       QUIT 

 +9                SET BCHNAME=$PIECE(^AUPNPRVT(DFN,11,BCHMIFN,0),U)

                   IF BCHNAME=""

                       QUIT 

 +10               IF $PIECE(^AUTNINS(BCHNAME,0),U)["AHCCCS"

                       QUIT 

 +11               IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U,6)>D

                       QUIT 

 +12      ;IHS/CMI/LAB - patch 6 replaced BCHACE with D 9/21/98

                   IF $PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U,7)]""

                       IF $PIECE(^(0),U,7)<D

                           QUIT 

 +13               SET BCHPCNT=BCHPCNT+1

                   SET BCHPRNM(BCHPCNT)=$PIECE(^AUTNINS($PIECE(^AUPNPRVT(P,11,BCHMIFN,0),U),0),U)

 +14      ;begin Y2K

 +15      ;S BCHPCNT=BCHPCNT+1,Y=$P(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6),Z=$P(^(0),U,7),BCHPRNM(BCHPCNT)=$E(Y,4,5)_"/"_$E(Y,6,7)_"/"_$E(Y,2,3)_"-" I Z]"" S BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$E(Z,4,5)_"/"_$E(Z,6,7)_"/"_$E(Y,2,3) ;Y2000

 +16      ;Y2000

                   SET BCHPCNT=BCHPCNT+1

                   SET Y=$PIECE(^AUPNPRVT(DFN,11,BCHMIFN,0),U,6)

                   SET Z=$PIECE(^(0),U,7)

                   SET BCHPRNM(BCHPCNT)=$EXTRACT(Y,4,5)_"/"_$EXTRACT(Y,6,7)_"/"_(1700+$EXTRACT(Y,1,3))_"-"

 +17      ;Y2000

                   IF Z]""

                       SET BCHPRNM(BCHPCNT)=BCHPRNM(BCHPCNT)_$EXTRACT(Z,4,5)_"/"_$EXTRACT(Z,6,7)_"/"_(1700+$EXTRACT(Z,1,3))

 +18      ;end Y2K

 +19               QUIT 

               End DoDot:1

PIX       ;

 +1        QUIT