BGP4DPE3.m

BGP4DPE3 ;IHS/CMI/LAB - patient ed report; 

 ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 ;

 ;

SET73 ;EP

 I BGPTIME=2 D SET73P Q

 I BGPTIME=3 D SET73B Q

 I '$D(^BGPPEDCJ(BGPRPT,18,0)) S ^BGPPEDCJ(BGPRPT,18,0)="^90552.1218A^0^0"

 S Z=$O(^BGPPEDCJ(BGPRPT,18,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDCJ(BGPRPT,18,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,18,Z,0),U,3)+BGPC

 S Z=$P(^BGPPEDCJ(BGPRPT,18,0),U,3)+BGPC,$P(^BGPPEDCJ(BGPRPT,18,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,18,0),U,4)=Z

 S ^BGPPEDCJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_BGPC

 S ^BGPPEDCJ(BGPRPT,18,"B",BGPT,Z)=""

 Q

SET73P ;

 I '$D(^BGPPEDPJ(BGPRPT,18,0)) S ^BGPPEDPJ(BGPRPT,18,0)="^90552.1318A^0^0"

 S Z=$O(^BGPPEDPJ(BGPRPT,18,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDPJ(BGPRPT,18,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,18,Z,0),U,3)+1

 S Z=$P(^BGPPEDPJ(BGPRPT,18,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,18,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,18,0),U,4)=Z

 S ^BGPPEDPJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDPJ(BGPRPT,18,"B",BGPT,Z)=""

 Q

SET73B ;

 I '$D(^BGPPEDBJ(BGPRPT,18,0)) S ^BGPPEDBJ(BGPRPT,18,0)="^90552.1418A^0^0"

 S Z=$O(^BGPPEDBJ(BGPRPT,18,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDBJ(BGPRPT,18,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,18,Z,0),U,3)+1

 S Z=$P(^BGPPEDBJ(BGPRPT,18,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,18,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,18,0),U,4)=Z

 S ^BGPPEDBJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDBJ(BGPRPT,18,"B",BGPT,Z)=""

 Q

SET74 ;EP

 I BGPTIME=2 D SET74P Q

 I BGPTIME=3 D SET74B Q

 I '$D(^BGPPEDCJ(BGPRPT,19,0)) S ^BGPPEDCJ(BGPRPT,19,0)="^90552.1219A^0^0"

 S Z=$O(^BGPPEDCJ(BGPRPT,19,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDCJ(BGPRPT,19,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,19,Z,0),U,3)+BGPC

 S Z=$P(^BGPPEDCJ(BGPRPT,19,0),U,3)+BGPC,$P(^BGPPEDCJ(BGPRPT,19,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,19,0),U,4)=Z

 S ^BGPPEDCJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_BGPC

 S ^BGPPEDCJ(BGPRPT,19,"B",BGPT,Z)=""

 Q

SET74P ;

 I '$D(^BGPPEDPJ(BGPRPT,19,0)) S ^BGPPEDPJ(BGPRPT,19,0)="^90552.1319A^0^0"

 S Z=$O(^BGPPEDPJ(BGPRPT,19,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDPJ(BGPRPT,19,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,19,Z,0),U,3)+1

 S Z=$P(^BGPPEDPJ(BGPRPT,19,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,19,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,19,0),U,4)=Z

 S ^BGPPEDPJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDPJ(BGPRPT,19,"B",BGPT,Z)=""

 Q

SET74B ;

 I '$D(^BGPPEDBJ(BGPRPT,19,0)) S ^BGPPEDBJ(BGPRPT,19,0)="^90552.1419A^0^0"

 S Z=$O(^BGPPEDBJ(BGPRPT,19,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDBJ(BGPRPT,19,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,19,Z,0),U,3)+1

 S Z=$P(^BGPPEDBJ(BGPRPT,19,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,19,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,19,0),U,4)=Z

 S ^BGPPEDBJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDBJ(BGPRPT,19,"B",BGPT,Z)=""

 Q

SET75 ;EP

 I BGPTIME=2 D SET75P Q

 I BGPTIME=3 D SET75B Q

 I '$D(^BGPPEDCJ(BGPRPT,21,0)) S ^BGPPEDCJ(BGPRPT,21,0)="^90552.1221A^0^0"

 S Z=$O(^BGPPEDCJ(BGPRPT,21,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDCJ(BGPRPT,21,Z,0),U,3)=$P(^BGPPEDCJ(BGPRPT,21,Z,0),U,3)+BGPC

 S Z=$P(^BGPPEDCJ(BGPRPT,21,0),U,3)+BGPC,$P(^BGPPEDCJ(BGPRPT,21,0),U,3)=Z,$P(^BGPPEDCJ(BGPRPT,21,0),U,4)=Z

 S ^BGPPEDCJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_BGPC

 S ^BGPPEDCJ(BGPRPT,21,"B",BGPT,Z)=""

 Q

SET75P ;

 I '$D(^BGPPEDPJ(BGPRPT,21,0)) S ^BGPPEDPJ(BGPRPT,21,0)="^90552.1321A^0^0"

 S Z=$O(^BGPPEDPJ(BGPRPT,21,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDPJ(BGPRPT,21,Z,0),U,3)=$P(^BGPPEDPJ(BGPRPT,21,Z,0),U,3)+1

 S Z=$P(^BGPPEDPJ(BGPRPT,21,0),U,3)+1,$P(^BGPPEDPJ(BGPRPT,21,0),U,3)=Z,$P(^BGPPEDPJ(BGPRPT,21,0),U,4)=Z

 S ^BGPPEDPJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDPJ(BGPRPT,21,"B",BGPT,Z)=""

 Q

SET75B ;

 I '$D(^BGPPEDBJ(BGPRPT,21,0)) S ^BGPPEDBJ(BGPRPT,21,0)="^90552.1421A^0^0"

 S Z=$O(^BGPPEDBJ(BGPRPT,21,"B",BGPT,0)) I Z D  Q

 .S $P(^BGPPEDBJ(BGPRPT,21,Z,0),U,3)=$P(^BGPPEDBJ(BGPRPT,21,Z,0),U,3)+1

 S Z=$P(^BGPPEDBJ(BGPRPT,21,0),U,3)+1,$P(^BGPPEDBJ(BGPRPT,21,0),U,3)=Z,$P(^BGPPEDBJ(BGPRPT,21,0),U,4)=Z

 S ^BGPPEDBJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_1

 S ^BGPPEDBJ(BGPRPT,21,"B",BGPT,Z)=""

 Q

BGP4DPE3  ;IHS/CMI/LAB - patient ed report; 

 +1       ;;14.1;IHS CLINICAL REPORTING;;MAY 29, 2014;Build 114

 +2       ;

 +3       ;

SET73     ;EP

 +1        IF BGPTIME=2

               DO SET73P

               QUIT 

 +2        IF BGPTIME=3

               DO SET73B

               QUIT 

 +3        IF '$DATA(^BGPPEDCJ(BGPRPT,18,0))

               SET ^BGPPEDCJ(BGPRPT,18,0)="^90552.1218A^0^0"

 +4        SET Z=$ORDER(^BGPPEDCJ(BGPRPT,18,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +5                SET $PIECE(^BGPPEDCJ(BGPRPT,18,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,18,Z,0),U,3)+BGPC

               End DoDot:1

               QUIT 

 +6        SET Z=$PIECE(^BGPPEDCJ(BGPRPT,18,0),U,3)+BGPC

           SET $PIECE(^BGPPEDCJ(BGPRPT,18,0),U,3)=Z

           SET $PIECE(^BGPPEDCJ(BGPRPT,18,0),U,4)=Z

 +7        SET ^BGPPEDCJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_BGPC

 +8        SET ^BGPPEDCJ(BGPRPT,18,"B",BGPT,Z)=""

 +9        QUIT 

SET73P    ;

 +1        IF '$DATA(^BGPPEDPJ(BGPRPT,18,0))

               SET ^BGPPEDPJ(BGPRPT,18,0)="^90552.1318A^0^0"

 +2        SET Z=$ORDER(^BGPPEDPJ(BGPRPT,18,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDPJ(BGPRPT,18,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,18,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDPJ(BGPRPT,18,0),U,3)+1

           SET $PIECE(^BGPPEDPJ(BGPRPT,18,0),U,3)=Z

           SET $PIECE(^BGPPEDPJ(BGPRPT,18,0),U,4)=Z

 +5        SET ^BGPPEDPJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDPJ(BGPRPT,18,"B",BGPT,Z)=""

 +7        QUIT 

SET73B    ;

 +1        IF '$DATA(^BGPPEDBJ(BGPRPT,18,0))

               SET ^BGPPEDBJ(BGPRPT,18,0)="^90552.1418A^0^0"

 +2        SET Z=$ORDER(^BGPPEDBJ(BGPRPT,18,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDBJ(BGPRPT,18,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,18,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDBJ(BGPRPT,18,0),U,3)+1

           SET $PIECE(^BGPPEDBJ(BGPRPT,18,0),U,3)=Z

           SET $PIECE(^BGPPEDBJ(BGPRPT,18,0),U,4)=Z

 +5        SET ^BGPPEDBJ(BGPRPT,18,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDBJ(BGPRPT,18,"B",BGPT,Z)=""

 +7        QUIT 

SET74     ;EP

 +1        IF BGPTIME=2

               DO SET74P

               QUIT 

 +2        IF BGPTIME=3

               DO SET74B

               QUIT 

 +3        IF '$DATA(^BGPPEDCJ(BGPRPT,19,0))

               SET ^BGPPEDCJ(BGPRPT,19,0)="^90552.1219A^0^0"

 +4        SET Z=$ORDER(^BGPPEDCJ(BGPRPT,19,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +5                SET $PIECE(^BGPPEDCJ(BGPRPT,19,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,19,Z,0),U,3)+BGPC

               End DoDot:1

               QUIT 

 +6        SET Z=$PIECE(^BGPPEDCJ(BGPRPT,19,0),U,3)+BGPC

           SET $PIECE(^BGPPEDCJ(BGPRPT,19,0),U,3)=Z

           SET $PIECE(^BGPPEDCJ(BGPRPT,19,0),U,4)=Z

 +7        SET ^BGPPEDCJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_BGPC

 +8        SET ^BGPPEDCJ(BGPRPT,19,"B",BGPT,Z)=""

 +9        QUIT 

SET74P    ;

 +1        IF '$DATA(^BGPPEDPJ(BGPRPT,19,0))

               SET ^BGPPEDPJ(BGPRPT,19,0)="^90552.1319A^0^0"

 +2        SET Z=$ORDER(^BGPPEDPJ(BGPRPT,19,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDPJ(BGPRPT,19,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,19,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDPJ(BGPRPT,19,0),U,3)+1

           SET $PIECE(^BGPPEDPJ(BGPRPT,19,0),U,3)=Z

           SET $PIECE(^BGPPEDPJ(BGPRPT,19,0),U,4)=Z

 +5        SET ^BGPPEDPJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDPJ(BGPRPT,19,"B",BGPT,Z)=""

 +7        QUIT 

SET74B    ;

 +1        IF '$DATA(^BGPPEDBJ(BGPRPT,19,0))

               SET ^BGPPEDBJ(BGPRPT,19,0)="^90552.1419A^0^0"

 +2        SET Z=$ORDER(^BGPPEDBJ(BGPRPT,19,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDBJ(BGPRPT,19,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,19,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDBJ(BGPRPT,19,0),U,3)+1

           SET $PIECE(^BGPPEDBJ(BGPRPT,19,0),U,3)=Z

           SET $PIECE(^BGPPEDBJ(BGPRPT,19,0),U,4)=Z

 +5        SET ^BGPPEDBJ(BGPRPT,19,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDBJ(BGPRPT,19,"B",BGPT,Z)=""

 +7        QUIT 

SET75     ;EP

 +1        IF BGPTIME=2

               DO SET75P

               QUIT 

 +2        IF BGPTIME=3

               DO SET75B

               QUIT 

 +3        IF '$DATA(^BGPPEDCJ(BGPRPT,21,0))

               SET ^BGPPEDCJ(BGPRPT,21,0)="^90552.1221A^0^0"

 +4        SET Z=$ORDER(^BGPPEDCJ(BGPRPT,21,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +5                SET $PIECE(^BGPPEDCJ(BGPRPT,21,Z,0),U,3)=$PIECE(^BGPPEDCJ(BGPRPT,21,Z,0),U,3)+BGPC

               End DoDot:1

               QUIT 

 +6        SET Z=$PIECE(^BGPPEDCJ(BGPRPT,21,0),U,3)+BGPC

           SET $PIECE(^BGPPEDCJ(BGPRPT,21,0),U,3)=Z

           SET $PIECE(^BGPPEDCJ(BGPRPT,21,0),U,4)=Z

 +7        SET ^BGPPEDCJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_BGPC

 +8        SET ^BGPPEDCJ(BGPRPT,21,"B",BGPT,Z)=""

 +9        QUIT 

SET75P    ;

 +1        IF '$DATA(^BGPPEDPJ(BGPRPT,21,0))

               SET ^BGPPEDPJ(BGPRPT,21,0)="^90552.1321A^0^0"

 +2        SET Z=$ORDER(^BGPPEDPJ(BGPRPT,21,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDPJ(BGPRPT,21,Z,0),U,3)=$PIECE(^BGPPEDPJ(BGPRPT,21,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDPJ(BGPRPT,21,0),U,3)+1

           SET $PIECE(^BGPPEDPJ(BGPRPT,21,0),U,3)=Z

           SET $PIECE(^BGPPEDPJ(BGPRPT,21,0),U,4)=Z

 +5        SET ^BGPPEDPJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDPJ(BGPRPT,21,"B",BGPT,Z)=""

 +7        QUIT 

SET75B    ;

 +1        IF '$DATA(^BGPPEDBJ(BGPRPT,21,0))

               SET ^BGPPEDBJ(BGPRPT,21,0)="^90552.1421A^0^0"

 +2        SET Z=$ORDER(^BGPPEDBJ(BGPRPT,21,"B",BGPT,0))

           IF Z

               Begin DoDot:1

 +3                SET $PIECE(^BGPPEDBJ(BGPRPT,21,Z,0),U,3)=$PIECE(^BGPPEDBJ(BGPRPT,21,Z,0),U,3)+1

               End DoDot:1

               QUIT 

 +4        SET Z=$PIECE(^BGPPEDBJ(BGPRPT,21,0),U,3)+1

           SET $PIECE(^BGPPEDBJ(BGPRPT,21,0),U,3)=Z

           SET $PIECE(^BGPPEDBJ(BGPRPT,21,0),U,4)=Z

 +5        SET ^BGPPEDBJ(BGPRPT,21,Z,0)=BGPT_U_BGPT_U_1

 +6        SET ^BGPPEDBJ(BGPRPT,21,"B",BGPT,Z)=""

 +7        QUIT