BGP8PCCI.m

BGP8PCCI ;IHS/CMI/LAB - AREA GPRA; ; 02 Feb 2018  11:25 AM

 ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 ;

CALCIND ;EP

 S BGPIC=0 F  S BGPIC=$O(BGPIND(BGPIC)) Q:BGPIC'=+BGPIC  D

 .K BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 .F X=1:1:10 S Y="BGPN"_X K @Y

 .F X=1:1:10 S Y="BGPD"_X K @Y

 .K ^TMP($J)

 .S BGPVALUE=""

 .I $D(^BGPINDR(BGPIC,1)) X ^BGPINDR(BGPIC,1)

 .K BGPG,BGPC,BGPALLED,BGPVAL,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 .I $D(BGPSTOP) Q  ;no need to set since no num/denom

 .;loop each individual to set numerator and denominator

 .S BGPI=0 F  S BGPI=$O(^BGPINDRC("B",BGPIC,BGPI)) Q:BGPI'=+BGPI  D

 ..S (BGPNUM,BGPDEN)=0

 ..X ^BGPINDRC(BGPI,1)

 ..X ^BGPINDRC(BGPI,2) ;denominator 1 or 0

 ..;set field counter

 ..S BGPNF=$P(^BGPINDRC(BGPI,0),U,9)

 ..S BGPN=$P(^DD(90560.03,BGPNF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)

 ..D S(BGPRPT,BGPGBL,N,P,BGPNUM)

 ..S BGPDF=$P(^BGPINDRC(BGPI,0),U,8)

 ..S BGPN=$P(^DD(90560.03,BGPDF,0),U,4),N=$P(BGPN,";"),P=$P(BGPN,";",2)

 ..I BGPDEN'="NO" D S(BGPRPT,BGPGBL,N,P,BGPDEN)

 .K BGPNUMV

 .I $D(BGPLIST(BGPIC)) D STMP^BGP8UTL

 .K BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18,BGPD19,BGPD20,BGPD21,BGPD22,BGPD23,BGPD24,BGPD25,BGPD26

 .K BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

 Q

 ;

D(D) ;

 I D="" Q ""

 Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))

 ;

S(R,G,N,P,V) ;

 I 'V Q  ;no value to add

 S $P(@(G_R_","_N_")"),U,P)=$P($G(@(G_R_","_N_")")),U,P)+V

 Q

BGP8PCCI  ;IHS/CMI/LAB - AREA GPRA; ; 02 Feb 2018  11:25 AM

 +1       ;;18.1;IHS CLINICAL REPORTING;;MAY 25, 2018;Build 66

 +2       ;

CALCIND   ;EP

 +1        SET BGPIC=0

           FOR 

               SET BGPIC=$ORDER(BGPIND(BGPIC))

               IF BGPIC'=+BGPIC

                   QUIT 

               Begin DoDot:1

 +2                KILL BGPSTOP,BGPVAL,BGPVALUE,BGPG,BGPC,BGPALLED,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 +3                FOR X=1:1:10

                       SET Y="BGPN"_X

                       KILL @Y

 +4                FOR X=1:1:10

                       SET Y="BGPD"_X

                       KILL @Y

 +5                KILL ^TMP($JOB)

 +6                SET BGPVALUE=""

 +7                IF $DATA(^BGPINDR(BGPIC,1))

                       XECUTE ^BGPINDR(BGPIC,1)

 +8                KILL BGPG,BGPC,BGPALLED,BGPVAL,BGPV,A,B,C,D,E,F,G,H,I,J,K,M,N,O,P,Q,R,S,T,V,W,X,Y,Z

 +9       ;no need to set since no num/denom

                   IF $DATA(BGPSTOP)

                       QUIT 

 +10      ;loop each individual to set numerator and denominator

 +11               SET BGPI=0

                   FOR 

                       SET BGPI=$ORDER(^BGPINDRC("B",BGPIC,BGPI))

                       IF BGPI'=+BGPI

                           QUIT 

                       Begin DoDot:2

 +12                       SET (BGPNUM,BGPDEN)=0

 +13                       XECUTE ^BGPINDRC(BGPI,1)

 +14      ;denominator 1 or 0

                           XECUTE ^BGPINDRC(BGPI,2)

 +15      ;set field counter

 +16                       SET BGPNF=$PIECE(^BGPINDRC(BGPI,0),U,9)

 +17                       SET BGPN=$PIECE(^DD(90560.03,BGPNF,0),U,4)

                           SET N=$PIECE(BGPN,";")

                           SET P=$PIECE(BGPN,";",2)

 +18                       DO S(BGPRPT,BGPGBL,N,P,BGPNUM)

 +19                       SET BGPDF=$PIECE(^BGPINDRC(BGPI,0),U,8)

 +20                       SET BGPN=$PIECE(^DD(90560.03,BGPDF,0),U,4)

                           SET N=$PIECE(BGPN,";")

                           SET P=$PIECE(BGPN,";",2)

 +21                       IF BGPDEN'="NO"

                               DO S(BGPRPT,BGPGBL,N,P,BGPDEN)

                       End DoDot:2

 +22               KILL BGPNUMV

 +23               IF $DATA(BGPLIST(BGPIC))

                       DO STMP^BGP8UTL

 +24               KILL BGPD1,BGPD2,BGPD3,BGPD4,BGPD5,BGPD6,BGPD7,BGPD8,BGPD9,BGPD10,BGPD11,BGPD12,BGPD13,BGPD14,BGPD15,BGPD16,BGPD17,BGPD18,BGPD19,BGPD20,BGPD21,BGPD22,BGPD23,BGPD24,BGPD25,BGPD26

 +25               KILL BGPN1,BGPN2,BGPN3,BGPN4,BGPN5,BGPN6,BGPN7,BGPN8,BGPN9,BGPN10,BGPN11,BGPN12,BGPN13,BGPN14,BGPN15,BGPN16,BGPN17,BGPN18,BGPN19,BGPN20,BGPN21,BGPN22,BGPN23,BGPN24,BGPN25,BGPN26,BGPN27,BGPN28,BGPN29,BGPN30

               End DoDot:1

 +26       QUIT 

 +27      ;

D(D)      ;

 +1        IF D=""

               QUIT ""

 +2        QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_(1700+$EXTRACT(D,1,3))

 +3       ;

S(R,G,N,P,V) ;

 +1       ;no value to add

           IF 'V

               QUIT 

 +2        SET $PIECE(@(G_R_","_N_")"),U,P)=$PIECE($GET(@(G_R_","_N_")")),U,P)+V

 +3        QUIT