BPCSC2.m

BPCSC2 ; IHS/OIT/MJL - SPECIAL X-REF ROUTINES - ; [ 12/06/2007  11:53 AM ]

 ;;1.5;BPC;**1,4**;OCT 04, 2005

 ;

 ; BPCGREF  - Primary Global Reference

 ; BPCSBJGR - Subject Global Reference - Used if all of the entries are to be used under this node -- don't need to check a date

 ; BPCRVCRO - Reverse chronological date subscripted

 ;

SETUP ;

 S BGUCRFS=""

 S BPCVWNO=$P(BGUEND,"`",2),BPCLBONL=$P(BGUEND,"`",3),BPCRVCRO=1

 S BPCVWOPT=$P(BGUEND,"`",4),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:999999999)

 S (BGUBEGIN,BGUEND,BPCXLEVL)="",BPCC=0

 Q

 ;

VISIT ;

 I BPCSBJGR="" S BPCC=BPCC+1,BGUSUB(1)=BPCVIEN,BGUV(BGUFILE,88888)=$$PRIMPROV^APCLV(BPCVIEN,"N") D FIELDS^BGULIST Q

 S BPCSIEN=0 F  S BPCSIEN=$O(@BPCSBJGR@(BPCSIEN)) Q:'BPCSIEN  S BPCC=BPCC+1,BGUSUB(1)=BPCSIEN,BGUV(BGUFILE,88888)=$$PRIMPROV^APCLV(BPCSIEN,"N") D FIELDS^BGULIST

 Q

 ;

VSDTRNG ; Get visits for a patient for a date range

 S BPCGREF=$G(BPCGREF,"^AUPNVSIT(""AA"",BPCPIEN)")

 S BPCPIEN=$P(BGUBEGIN,"`"),BGUBEGIN=$P(BGUBEGIN,"`",2)

 D VSDTDR

 Q

VSDTDR ;

 I '$D(BGUDRIVR) D  Q

 .S BGUDRIVR="VSDTDR^BPCSC2",BPCSDATE=BGUBEGIN,BPCEDATE=$P(BGUEND,"`",1)

 .S BPCSDATE=$P(BGUEND,"`",1),BPCEDATE=$P(BGUEND,"`",2)

 .S BPCVWNO=$P(BGUEND,"`",3),BPCLBONL=$P(BGUEND,"`",4)

 .S BPCVWOPT=$P(BGUEND,"`",5),BGUMAX=$S('BPCVWOPT:BPCVWNO,1:999999)

 .D SETUP

 S BPCVWOPT="2",BPCSBJGR=$G(BPCSBJGR)

 D VSDTDR1,KILL

 Q

VSDTDR1 ;

 S:'(+BPCVWNO) BPCVWNO=10 S:BPCSDATE="" BPCSDATE="1/1/1980"

 S:BPCEDATE="" BPCEDATE="T" S:BPCVWOPT="" BPCVWOPT="0"

 S:BPCLBONL="" BPCLBONL="1"

 D DT^DILF("",BPCSDATE,.BPCSDAT)

 I BPCSDAT=-1 S BPCSDATE="1/1/1980" D DT^DILF("",BPCSDATE,.BPCSDAT)

 D DT^DILF("",BPCEDATE,.BPCEDAT)

 I BPCEDAT=-1 S BPCEDATE="T" D DT^DILF("",BPCEDATE,.BPCEDAT)

 S BPCC=0,BPCX=0,BPCLIM=$S(BPCVWOPT="0":BPCVWNO,1:999999)

 I BPCRVCRO S BPCSDAT=9999999-BPCSDAT,BPCEDAT=9999999-BPCEDAT

 I BPCXLEVL'="" D @BPCXLEVL Q

VSDTDR2 ;

 I BPCRVCRO D  Q

 .S BPCX=$O(@BPCGREF@(BPCEDAT),-1) F  S BPCX=$O(@BPCGREF@(BPCX)) Q:'BPCX  Q:BPCX\1>BPCSDAT  D  Q:BPCC=BPCLIM

 ..S BPCVIEN=0 F  S BPCVIEN=$O(@BPCGREF@(BPCX,BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  D VISIT

 S BPCX=$O(@BPCGREF@(BPCSDAT),-1) F  S BPCX=$O(@BPCGREF@(BPCX)) Q:'BPCX  Q:BPCX\1>BPCEDAT  D  Q:BPCC=BPCLIM

 .S BPCVIEN=0 F  S BPCVIEN=$O(@BPCGREF@(BPCX,BPCVIEN)) Q:'BPCVIEN  Q:BPCC=BPCLIM  D VISIT

 Q

 ;

VED ; Get V PATIENT ED

 ;

 S BPCGREF="^AUPNVPED(""AA"",BPCPIEN)"

 D VSDTRNG

 Q

 ;

VHF ; Get V HEALTH FACTORS

 S BPCGREF="^AUPNVHF(""AA"",BPCPIEN)",BPCXLEVL="VHF1"

 D VSDTRNG

 Q

 ;

VHF1 ; V HEALTH FACTORS XTRA level

 S BPCGREF="^AUPNVHF(""AA"",BPCPIEN,BPCXL)"

 S BPCXL=0 F  S BPCXL=$O(@BPCGREF) Q:'BPCXL  D VSDTDR2

 Q

 ;

VEXAM ; Get V EXAMS

 S BPCGREF="^AUPNVXAM(""AA"",BPCPIEN)",BPCXLEVL="VEXAM1"

 D VSDTRNG

 Q

 ;

VEXAM1 ; V EXAMS XTRA level

 S BPCGREF="^AUPNVXAM(""AA"",BPCPIEN,BPCXL)"

 S BPCXL=0 F  S BPCXL=$O(@BPCGREF) Q:'BPCXL  D VSDTDR2

 Q

 ;

ACTVCN ; Get Active Chart number -- only necessary for BPCDIVALL - Set BPCDUZ2=Loc of first active Chart.

 ;

 S BPCDZ2=0,BPCDUZ2=0 F  S BPCDZ2=$O(^AUPNPAT(BGUSVSB1(1),41,BPCDZ2)) Q:'BPCDZ2  D  Q:'BPCDZ2

 .S BPCX=^AUPNPAT(BGUSVSB1(1),41,BPCDZ2,0) I $P(BPCX,U,5)="" D

 ..I $G(BGUSVSUB(1))="D",BGUBEGIN'=$P(BPCX,U,2) Q

 ..S BPCDUZ2=BPCDZ2,BPCDZ2=0 Q

 S BGUV(BGUFILE,414141)=BPCDUZ2 K BPCDZ2,BPCX

 Q

 ;

ACTVCNG ;

 S BPCDZ2=0,BPCDUZ2=0 F  S BPCDZ2=$O(^AUPNPAT(BGUSUB(1),41,BPCDZ2)) Q:'BPCDZ2  D  Q:'BPCDZ2

 .S BPCX=^AUPNPAT(BGUSUB(1),41,BPCDZ2,0) I $P(BPCX,U,5)="" S BPCDUZ2=BPCDZ2,BPCDZ2=0 Q

 S BGUV(BGUFILE,414141)=BPCDUZ2 K BPCDZ2,BPCX

 Q

 ;

CSV(BPCCD,BPCDATE) ;

 S BPCCSVR=$S(BGUGBL="^ICPT(":"CPT^ICPTCOD",1:"") Q:BPCCSVR=""

 S @("BPCCSV="_"(""$$""_BPCCSVR_""(""_BPCCD_"",""_BPCDATE_"")"")")

 S @("BPCCSV="_BPCCSV),BPCCSV=$P(BPCCSV,U,3)

 S BGUV(BGUFILE,123123)=BPCCSV

 Q

 ;

KILL ;

 K BGUDRIVR,BPCC,BPCEDATE,BPCGREF,BPCGROUP,BPCLBONL,BPCLIM,BPCPIEN,BPCSBJGR,BPCSDATE,BPCSIEN,BPCRVCRO,BPCVIEN,BPCVWNO,BPCVWOPT,BPCX,BPCXL,BPCXLEVL

 Q

BPCSC2    ; IHS/OIT/MJL - SPECIAL X-REF ROUTINES - ; [ 12/06/2007  11:53 AM ]

 +1       ;;1.5;BPC;**1,4**;OCT 04, 2005

 +2       ;

 +3       ; BPCGREF  - Primary Global Reference

 +4       ; BPCSBJGR - Subject Global Reference - Used if all of the entries are to be used under this node -- don't need to check a date

 +5       ; BPCRVCRO - Reverse chronological date subscripted

 +6       ;

SETUP     ;

 +1        SET BGUCRFS=""

 +2        SET BPCVWNO=$PIECE(BGUEND,"`",2)

           SET BPCLBONL=$PIECE(BGUEND,"`",3)

           SET BPCRVCRO=1

 +3        SET BPCVWOPT=$PIECE(BGUEND,"`",4)

           SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:999999999)

 +4        SET (BGUBEGIN,BGUEND,BPCXLEVL)=""

           SET BPCC=0

 +5        QUIT 

 +6       ;

VISIT     ;

 +1        IF BPCSBJGR=""

               SET BPCC=BPCC+1

               SET BGUSUB(1)=BPCVIEN

               SET BGUV(BGUFILE,88888)=$$PRIMPROV^APCLV(BPCVIEN,"N")

               DO FIELDS^BGULIST

               QUIT 

 +2        SET BPCSIEN=0

           FOR 

               SET BPCSIEN=$ORDER(@BPCSBJGR@(BPCSIEN))

               IF 'BPCSIEN

                   QUIT 

               SET BPCC=BPCC+1

               SET BGUSUB(1)=BPCSIEN

               SET BGUV(BGUFILE,88888)=$$PRIMPROV^APCLV(BPCSIEN,"N")

               DO FIELDS^BGULIST

 +3        QUIT 

 +4       ;

VSDTRNG   ; Get visits for a patient for a date range

 +1        SET BPCGREF=$GET(BPCGREF,"^AUPNVSIT(""AA"",BPCPIEN)")

 +2        SET BPCPIEN=$PIECE(BGUBEGIN,"`")

           SET BGUBEGIN=$PIECE(BGUBEGIN,"`",2)

 +3        DO VSDTDR

 +4        QUIT 

VSDTDR    ;

 +1        IF '$DATA(BGUDRIVR)

               Begin DoDot:1

 +2                SET BGUDRIVR="VSDTDR^BPCSC2"

                   SET BPCSDATE=BGUBEGIN

                   SET BPCEDATE=$PIECE(BGUEND,"`",1)

 +3                SET BPCSDATE=$PIECE(BGUEND,"`",1)

                   SET BPCEDATE=$PIECE(BGUEND,"`",2)

 +4                SET BPCVWNO=$PIECE(BGUEND,"`",3)

                   SET BPCLBONL=$PIECE(BGUEND,"`",4)

 +5                SET BPCVWOPT=$PIECE(BGUEND,"`",5)

                   SET BGUMAX=$SELECT('BPCVWOPT:BPCVWNO,1:999999)

 +6                DO SETUP

               End DoDot:1

               QUIT 

 +7        SET BPCVWOPT="2"

           SET BPCSBJGR=$GET(BPCSBJGR)

 +8        DO VSDTDR1

           DO KILL

 +9        QUIT 

VSDTDR1   ;

 +1        IF '(+BPCVWNO)

               SET BPCVWNO=10

           IF BPCSDATE=""

               SET BPCSDATE="1/1/1980"

 +2        IF BPCEDATE=""

               SET BPCEDATE="T"

           IF BPCVWOPT=""

               SET BPCVWOPT="0"

 +3        IF BPCLBONL=""

               SET BPCLBONL="1"

 +4        DO DT^DILF("",BPCSDATE,.BPCSDAT)

 +5        IF BPCSDAT=-1

               SET BPCSDATE="1/1/1980"

               DO DT^DILF("",BPCSDATE,.BPCSDAT)

 +6        DO DT^DILF("",BPCEDATE,.BPCEDAT)

 +7        IF BPCEDAT=-1

               SET BPCEDATE="T"

               DO DT^DILF("",BPCEDATE,.BPCEDAT)

 +8        SET BPCC=0

           SET BPCX=0

           SET BPCLIM=$SELECT(BPCVWOPT="0":BPCVWNO,1:999999)

 +9        IF BPCRVCRO

               SET BPCSDAT=9999999-BPCSDAT

               SET BPCEDAT=9999999-BPCEDAT

 +10       IF BPCXLEVL'=""

               DO @BPCXLEVL

               QUIT 

VSDTDR2   ;

 +1        IF BPCRVCRO

               Begin DoDot:1

 +2                SET BPCX=$ORDER(@BPCGREF@(BPCEDAT),-1)

                   FOR 

                       SET BPCX=$ORDER(@BPCGREF@(BPCX))

                       IF 'BPCX

                           QUIT 

                       IF BPCX\1>BPCSDAT

                           QUIT 

                       Begin DoDot:2

 +3                        SET BPCVIEN=0

                           FOR 

                               SET BPCVIEN=$ORDER(@BPCGREF@(BPCX,BPCVIEN))

                               IF 'BPCVIEN

                                   QUIT 

                               IF BPCC=BPCLIM

                                   QUIT 

                               DO VISIT

                       End DoDot:2

                       IF BPCC=BPCLIM

                           QUIT 

               End DoDot:1

               QUIT 

 +4        SET BPCX=$ORDER(@BPCGREF@(BPCSDAT),-1)

           FOR 

               SET BPCX=$ORDER(@BPCGREF@(BPCX))

               IF 'BPCX

                   QUIT 

               IF BPCX\1>BPCEDAT

                   QUIT 

               Begin DoDot:1

 +5                SET BPCVIEN=0

                   FOR 

                       SET BPCVIEN=$ORDER(@BPCGREF@(BPCX,BPCVIEN))

                       IF 'BPCVIEN

                           QUIT 

                       IF BPCC=BPCLIM

                           QUIT 

                       DO VISIT

               End DoDot:1

               IF BPCC=BPCLIM

                   QUIT 

 +6        QUIT 

 +7       ;

VED       ; Get V PATIENT ED

 +1       ;

 +2        SET BPCGREF="^AUPNVPED(""AA"",BPCPIEN)"

 +3        DO VSDTRNG

 +4        QUIT 

 +5       ;

VHF       ; Get V HEALTH FACTORS

 +1        SET BPCGREF="^AUPNVHF(""AA"",BPCPIEN)"

           SET BPCXLEVL="VHF1"

 +2        DO VSDTRNG

 +3        QUIT 

 +4       ;

VHF1      ; V HEALTH FACTORS XTRA level

 +1        SET BPCGREF="^AUPNVHF(""AA"",BPCPIEN,BPCXL)"

 +2        SET BPCXL=0

           FOR 

               SET BPCXL=$ORDER(@BPCGREF)

               IF 'BPCXL

                   QUIT 

               DO VSDTDR2

 +3        QUIT 

 +4       ;

VEXAM     ; Get V EXAMS

 +1        SET BPCGREF="^AUPNVXAM(""AA"",BPCPIEN)"

           SET BPCXLEVL="VEXAM1"

 +2        DO VSDTRNG

 +3        QUIT 

 +4       ;

VEXAM1    ; V EXAMS XTRA level

 +1        SET BPCGREF="^AUPNVXAM(""AA"",BPCPIEN,BPCXL)"

 +2        SET BPCXL=0

           FOR 

               SET BPCXL=$ORDER(@BPCGREF)

               IF 'BPCXL

                   QUIT 

               DO VSDTDR2

 +3        QUIT 

 +4       ;

ACTVCN    ; Get Active Chart number -- only necessary for BPCDIVALL - Set BPCDUZ2=Loc of first active Chart.

 +1       ;

 +2        SET BPCDZ2=0

           SET BPCDUZ2=0

           FOR 

               SET BPCDZ2=$ORDER(^AUPNPAT(BGUSVSB1(1),41,BPCDZ2))

               IF 'BPCDZ2

                   QUIT 

               Begin DoDot:1

 +3                SET BPCX=^AUPNPAT(BGUSVSB1(1),41,BPCDZ2,0)

                   IF $PIECE(BPCX,U,5)=""

                       Begin DoDot:2

 +4                        IF $GET(BGUSVSUB(1))="D"

                               IF BGUBEGIN'=$PIECE(BPCX,U,2)

                                   QUIT 

 +5                        SET BPCDUZ2=BPCDZ2

                           SET BPCDZ2=0

                           QUIT 

                       End DoDot:2

               End DoDot:1

               IF 'BPCDZ2

                   QUIT 

 +6        SET BGUV(BGUFILE,414141)=BPCDUZ2

           KILL BPCDZ2,BPCX

 +7        QUIT 

 +8       ;

ACTVCNG   ;

 +1        SET BPCDZ2=0

           SET BPCDUZ2=0

           FOR 

               SET BPCDZ2=$ORDER(^AUPNPAT(BGUSUB(1),41,BPCDZ2))

               IF 'BPCDZ2

                   QUIT 

               Begin DoDot:1

 +2                SET BPCX=^AUPNPAT(BGUSUB(1),41,BPCDZ2,0)

                   IF $PIECE(BPCX,U,5)=""

                       SET BPCDUZ2=BPCDZ2

                       SET BPCDZ2=0

                       QUIT 

               End DoDot:1

               IF 'BPCDZ2

                   QUIT 

 +3        SET BGUV(BGUFILE,414141)=BPCDUZ2

           KILL BPCDZ2,BPCX

 +4        QUIT 

 +5       ;

CSV(BPCCD,BPCDATE) ;

 +1        SET BPCCSVR=$SELECT(BGUGBL="^ICPT(":"CPT^ICPTCOD",1:"")

           IF BPCCSVR=""

               QUIT 

 +2        SET @("BPCCSV="_"(""$$""_BPCCSVR_""(""_BPCCD_"",""_BPCDATE_"")"")")

 +3        SET @("BPCCSV="_BPCCSV)

           SET BPCCSV=$PIECE(BPCCSV,U,3)

 +4        SET BGUV(BGUFILE,123123)=BPCCSV

 +5        QUIT 

 +6       ;

KILL      ;

 +1        KILL BGUDRIVR,BPCC,BPCEDATE,BPCGREF,BPCGROUP,BPCLBONL,BPCLIM,BPCPIEN,BPCSBJGR,BPCSDATE,BPCSIEN,BPCRVCRO,BPCVIEN,BPCVWNO,BPCVWOPT,BPCX,BPCXL,BPCXLEVL

 +2        QUIT