APCLPN1.m

APCLPN1 ; IHS/CMI/LAB - PROVIDER NARRATIVE LISTING ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

START ;

 S APCLBT=$H

 K ^XTMP("APCLPN",APCLJOB,APCLBTH)

 D XTMP^APCLOSUT("APCLPN","PCC PROV NARR REVIEW")

V ; Run by visit date

 S APCLODAT=APCLSD_".9999" F  S APCLODAT=$O(^AUPNVSIT("B",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D V1

 ;

END ;

 S APCLET=$H

 Q

V1 ;

 S V="" F  S V=$O(^AUPNVSIT("B",APCLODAT,V)) Q:V'=+V  I $D(^AUPNVSIT(V,0)) S APCLVREC=^(0) D

 .K APCLSKIP

 .Q:'$P(APCLVREC,U,9)

 .Q:$P(APCLVREC,U,11)

 .Q:'$D(^AUPNVPOV("AD",V))

 .Q:'$D(^AUPNVPRV("AD",V))

 .S B=0 F  S B=$O(^AUPNVPRV("AD",V,B)) Q:B=""  D

 ..I APCLPRIM,$P(^AUPNVPRV(B,0),U,4)'="P" Q

 ..S P=$P(^AUPNVPRV(B,0),U)

 ..S F=0

 ..D @APCLPSRT

 ..Q:'F

 ..S ^XTMP("APCLPN",APCLJOB,APCLBTH,S,V)=""

 ..Q

 .Q

 Q

 ;

P ;

 I $D(APCLCDIS) S S="" D D Q:S=""

 S S=P,F=1

 Q

 ;

O ;

 Q:APCLPROV'=P

 S S=P,F=1

 Q

 ;

D ;

 Q:'$D(^DIC(6,P))

 S Y=$P(^DIC(6,P,0),U,4)

 Q:Y=""

 Q:APCLDISC'=Y

 S S=APCLDISC

 S F=1

 Q

 ;

A ;

 Q:'$D(^DIC(6,P))

 S Y=$P(^DIC(6,P,0),U,4)

 Q:Y=""

 S S=Y

 S F=1

 Q

 ;

APCLPN1   ; IHS/CMI/LAB - PROVIDER NARRATIVE LISTING ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

START     ;

 +1        SET APCLBT=$HOROLOG

 +2        KILL ^XTMP("APCLPN",APCLJOB,APCLBTH)

 +3        DO XTMP^APCLOSUT("APCLPN","PCC PROV NARR REVIEW")

V         ; Run by visit date

 +1        SET APCLODAT=APCLSD_".9999"

           FOR 

               SET APCLODAT=$ORDER(^AUPNVSIT("B",APCLODAT))

               IF APCLODAT=""!((APCLODAT\1)>APCLED)

                   QUIT 

               DO V1

 +2       ;

END       ;

 +1        SET APCLET=$HOROLOG

 +2        QUIT 

V1        ;

 +1        SET V=""

           FOR 

               SET V=$ORDER(^AUPNVSIT("B",APCLODAT,V))

               IF V'=+V

                   QUIT 

               IF $DATA(^AUPNVSIT(V,0))

                   SET APCLVREC=^(0)

                   Begin DoDot:1

 +2                    KILL APCLSKIP

 +3                    IF '$PIECE(APCLVREC,U,9)

                           QUIT 

 +4                    IF $PIECE(APCLVREC,U,11)

                           QUIT 

 +5                    IF '$DATA(^AUPNVPOV("AD",V))

                           QUIT 

 +6                    IF '$DATA(^AUPNVPRV("AD",V))

                           QUIT 

 +7                    SET B=0

                       FOR 

                           SET B=$ORDER(^AUPNVPRV("AD",V,B))

                           IF B=""

                               QUIT 

                           Begin DoDot:2

 +8                            IF APCLPRIM

                                   IF $PIECE(^AUPNVPRV(B,0),U,4)'="P"

                                       QUIT 

 +9                            SET P=$PIECE(^AUPNVPRV(B,0),U)

 +10                           SET F=0

 +11                           DO @APCLPSRT

 +12                           IF 'F

                                   QUIT 

 +13                           SET ^XTMP("APCLPN",APCLJOB,APCLBTH,S,V)=""

 +14                           QUIT 

                           End DoDot:2

 +15                   QUIT 

                   End DoDot:1

 +16       QUIT 

 +17      ;

P         ;

 +1        IF $DATA(APCLCDIS)

               SET S=""

               DO D

               IF S=""

                   QUIT 

 +2        SET S=P

           SET F=1

 +3        QUIT 

 +4       ;

O         ;

 +1        IF APCLPROV'=P

               QUIT 

 +2        SET S=P

           SET F=1

 +3        QUIT 

 +4       ;

D         ;

 +1        IF '$DATA(^DIC(6,P))

               QUIT 

 +2        SET Y=$PIECE(^DIC(6,P,0),U,4)

 +3        IF Y=""

               QUIT 

 +4        IF APCLDISC'=Y

               QUIT 

 +5        SET S=APCLDISC

 +6        SET F=1

 +7        QUIT 

 +8       ;

A         ;

 +1        IF '$DATA(^DIC(6,P))

               QUIT 

 +2        SET Y=$PIECE(^DIC(6,P,0),U,4)

 +3        IF Y=""

               QUIT 

 +4        SET S=Y

 +5        SET F=1

 +6        QUIT 

 +7       ;