BPCBHADM.m

BPCBHADM ; IHS/OIT/MJL - BEHAVIORAL HEALTH SPECIAL CROSSREFERENCE FOR LOADING LISTVIEW FOR ADM ;

 ;;1.5;BPC;;MAY 26, 2005

 ;

ADM ; Get EDUCATION PROTOCOLS

 ;

 I '$D(BGUDRIVR) D  Q

 .S BGUDRIVR="ADM^BPCBHADM",BGUCRFS="",BPCPIEN=BGUBEGIN

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

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

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

 .S (BGUBEGIN,BGUEND)=""

 S BPCVWOPT="2"

 D ADM1

 Q

ADM1 ;

 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)

 S BPCCTYPE=$O(^AMHTSET("B","ADMINISTRATIVE",""))

 ;F  S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX  D  Q:BPCC=BPCLIM

 S BPCX=$O(^AMHREC("AD",BPCSDAT),-1) F  S BPCX=$O(^AMHREC("AD",BPCX)) Q:'BPCX  Q:BPCX>BPCEDAT  D  Q:BPCC=BPCLIM

 .S BPCVIEN=0 F  S BPCVIEN=$O(^AMHREC("AD",BPCX,BPCVIEN)) Q:'BPCVIEN  D  Q:BPCC=BPCLIM

 ..Q:$P(^AMHREC(BPCVIEN,0),U,7)'=BPCCTYPE

 ..S BPCC=BPCC+1,BGUSUB(1)=BPCVIEN,BGUV(BGUFILE,99999)=$O(^AMHRPRO("AD",BPCVIEN,0))

 ..S BGUV(BGUFILE,88888)=0 F  S BGUV(BGUFILE,88888)=$O(^AMHRPROV("AD",BPCVIEN,BGUV(BGUFILE,88888))),BGUV(BGUFILE,99999)=$O(^AMHRPRO("AD",BPCVIEN,0)) Q:BGUV(BGUFILE,88888)=""  Q:$P(^AMHRPROV(BGUV(BGUFILE,88888),0),U,4)="P"

 ..D FIELDS^BGULIST

 Q

BPCBHADM  ; IHS/OIT/MJL - BEHAVIORAL HEALTH SPECIAL CROSSREFERENCE FOR LOADING LISTVIEW FOR ADM ;

 +1       ;;1.5;BPC;;MAY 26, 2005

 +2       ;

ADM       ; Get EDUCATION PROTOCOLS

 +1       ;

 +2        IF '$DATA(BGUDRIVR)

               Begin DoDot:1

 +3                SET BGUDRIVR="ADM^BPCBHADM"

                   SET BGUCRFS=""

                   SET BPCPIEN=BGUBEGIN

 +4                SET BPCSDATE=BGUBEGIN

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

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

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

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

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

 +7                SET (BGUBEGIN,BGUEND)=""

               End DoDot:1

               QUIT 

 +8        SET BPCVWOPT="2"

 +9        DO ADM1

 +10       QUIT 

ADM1      ;

 +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        SET BPCCTYPE=$ORDER(^AMHTSET("B","ADMINISTRATIVE",""))

 +10      ;F  S BPCX=$O(^AUPNVSIT("AA",BPCPIEN,BPCX)) Q:'BPCX  D  Q:BPCC=BPCLIM

 +11       SET BPCX=$ORDER(^AMHREC("AD",BPCSDAT),-1)

           FOR 

               SET BPCX=$ORDER(^AMHREC("AD",BPCX))

               IF 'BPCX

                   QUIT 

               IF BPCX>BPCEDAT

                   QUIT 

               Begin DoDot:1

 +12               SET BPCVIEN=0

                   FOR 

                       SET BPCVIEN=$ORDER(^AMHREC("AD",BPCX,BPCVIEN))

                       IF 'BPCVIEN

                           QUIT 

                       Begin DoDot:2

 +13                       IF $PIECE(^AMHREC(BPCVIEN,0),U,7)'=BPCCTYPE

                               QUIT 

 +14                       SET BPCC=BPCC+1

                           SET BGUSUB(1)=BPCVIEN

                           SET BGUV(BGUFILE,99999)=$ORDER(^AMHRPRO("AD",BPCVIEN,0))

 +15                       SET BGUV(BGUFILE,88888)=0

                           FOR 

                               SET BGUV(BGUFILE,88888)=$ORDER(^AMHRPROV("AD",BPCVIEN,BGUV(BGUFILE,88888)))

                               SET BGUV(BGUFILE,99999)=$ORDER(^AMHRPRO("AD",BPCVIEN,0))

                               IF BGUV(BGUFILE,88888)=""

                                   QUIT 

                               IF $PIECE(^AMHRPROV(BGUV(BGUFILE,88888),0),U,4)="P"

                                   QUIT 

 +16                       DO FIELDS^BGULIST

                       End DoDot:2

                       IF BPCC=BPCLIM

                           QUIT 

               End DoDot:1

               IF BPCC=BPCLIM

                   QUIT 

 +17       QUIT