Routine: BKMVPG

BKMVPG ;PRXM/HC/ALA - PROVIDER GUIDELINES LISTMAN ; 06-APR-2006

 ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011

EN ; -- main entry point for BKMV GUIDELINES

 D EN^VALM("BKMV GUIDELINES")

HDR ; -- header code

 S WIDTH=80   ; Report width - 80 columns

 S END="*** END OF REPORT ***"

 K VALMHDR

 N HDRSTR,DA,IENS,BKMI,BKM,BKMSUB,BKMSUB1,BKMSUB2

 S BKMI=0

 S HDRSTR1=" "_$$GET1^DIQ(200,DUZ_",","1","E")

 S DA=$G(DUZ(2)),IENS=$$IENS^DILF(.DA),HDRSTR2=$$GET1^DIQ(4,IENS,.01,"E")

 S BKMI=BKMI+1

 S VALMHDR(BKMI)=HDRSTR1_" "_$$PAD^BKMIXX4("","<"," ",(WIDTH-$L(HDRSTR1))-$L(HDRSTR2)\2)_HDRSTR2

 ; Subheaders - parse if too long

 S (BKMSUB1,BKMSUB2)=""

 S BKMSUB=$P($G(^BKM(90453,BKMGL,0)),U)

 I BKMSUB'="" D

 . S BKM=$L(BKMSUB)\2

 . I $E(BKMSUB,BKM)=" " S BKMSUB1=$E(BKMSUB,1,BKM),BKMSUB2=$E(BKMSUB,BKM+1,$L(BKMSUB))

 . I $L(BKMSUB)'>50 S BKMSUB1=BKMSUB,BKMSUB2=""

 . I $L(BKMSUB)>50 D

 . . F BKM=40:1:$L(BKMSUB) Q:$E(BKMSUB,BKM)=" "  D

 . .. I $E(BKMSUB,BKM)=" " S BKMSUB1=$E(BKMSUB,1,BKM),BKMSUB2=$E(BKMSUB,BKM+1,$L(BKMSUB))

 . S:BKMSUB1="" BKMSUB1=BKMSUB

. ;

 . S BKMI=BKMI+1

 . S VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",$L(HDRSTR1))_$$PAD^BKMIXX4("","<"," ",(WIDTH-$L(HDRSTR1))-$L(BKMSUB1)\2)_BKMSUB1

 . I BKMSUB2'="" D

 . . S BKMI=BKMI+1

 . . S VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",WIDTH-$L(BKMSUB2)\2)_BKMSUB2

 . S BKMSUB=0 F  S BKMSUB=$O(^BKM(90453,BKMGL,4,BKMSUB)) Q:'BKMSUB  D

 . . S BKMSUB1=$G(^BKM(90453,BKMGL,4,BKMSUB,0))

 . . S BKMI=BKMI+1

 . . S VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",WIDTH-$L(BKMSUB1)\2)_BKMSUB1

 S HDRSTR="",$P(HDRSTR,"-",79)=""

 S BKMI=BKMI+1

 S VALMHDR(BKMI)=HDRSTR

INIT ; -- init variables and list array

 S VALMCNT=0,WIDTH=80

 D HNOTE

 D RSRC

 D BODY

 ;S VALMCNT=30

HELP ; -- help code

 S X="?" D DISP^XQORM1 W !!

EXIT ; -- exit code

 K ^TMP("BKMVPG",$J),^UTILITY($J,"W")

 D CLEAN^VALM10

 D CLEAR^VALM1

 S VALMBCK="R"

 K HDRSTR1,HDRSTR2

EXPND ; -- expand code

HNOTE ;Header note

 NEW BKMHF,BKMLINE,DIWF,DIWR,DIWL,BKMTOTLN

 K ^UTILITY($J,"W")

 Q:'$D(^BKM(90453,BKMGL,3,0))

 S BKMHF=0 F  S BKMHF=$O(^BKM(90453,BKMGL,3,BKMHF)) Q:'BKMHF  D

 . I $P(^BKM(90453,BKMGL,3,BKMHF,0),U)'="H" Q

 . S DIWF="I6",DIWR=75,DIWL=6

 . S BKMLINE=0 F  S BKMLINE=$O(^BKM(90453,BKMGL,3,BKMHF,1,BKMLINE)) Q:'BKMLINE  D

 .. S X=^BKM(90453,BKMGL,3,BKMHF,1,BKMLINE,0) D ^DIWP

 S BKMTOTLN=0

 F  S BKMTOTLN=$O(^UTILITY($J,"W",6,BKMTOTLN)) Q:'BKMTOTLN  D

 . S VALMCNT=VALMCNT+1,^TMP("BKMVPG",$J,VALMCNT,0)=^UTILITY($J,"W",6,BKMTOTLN,0)

 K ^UTILITY($J,"W")

RSRC ;Resources print

 NEW BKMR,BKMRP

 K ^UTILITY($J,"W")

 Q:'$D(^BKM(90453,BKMGL,1,0))

 S BKMR=0 F  S BKMR=$O(^BKM(90453,BKMGL,1,BKMR)) Q:'BKMR  D

 . S DIWF="N",DIWR=80,DIWL=0

 . S X=^BKM(90453,BKMGL,1,BKMR,0)

 . S X=$$PAD^BKMIXX4("","<"," ",WIDTH-$L(X)\2)_X D ^DIWP

 S BKMTOTLN=0

 F  S BKMTOTLN=$O(^UTILITY($J,"W",0,BKMTOTLN)) Q:'BKMTOTLN  D

 . S VALMCNT=VALMCNT+1,^TMP("BKMVPG",$J,VALMCNT,0)=^UTILITY($J,"W",0,BKMTOTLN,0)

 K ^UTILITY($J,"W")

BODY ;  BODY OF GUIDELINES

 NEW BKMAC,BKMEN,BKMENHDR,BKMINDNT,BKMNWPG,BKMFIRSC

 S BKMAC=0 F  S BKMAC=$O(^BKM(90453,BKMGL,2,"AC",BKMAC)) Q:'BKMAC  D

 . S BKMEN=$O(^BKM(90453,BKMGL,2,"AC",BKMAC,0))

 . S BKMENHDR=$P(^BKM(90453,BKMGL,2,BKMEN,0),U,1)

 . S BKMINDNT=$P(^BKM(90453,BKMGL,2,BKMEN,0),U,2)*2

 . ; Build ^UTILITY($J,"W") here

 . D BFORM(BKMINDNT,BKMENHDR)

BFORM(BKMIND,BKMHDRT) ;PRINT TEXT BODY

 NEW BKMLINE,X,Y,BKMTOTLN,BKMI

 K ^UTILITY($J,"W")

 S DIWF="N",DIWR=77,DIWL=6

 S BKMLINE=0 F  S BKMLINE=$O(^BKM(90453,BKMGL,2,BKMEN,1,BKMLINE)) Q:'BKMLINE  D

 . S X=^BKM(90453,BKMGL,2,BKMEN,1,BKMLINE,0) D ^DIWP

 S VALMCNT=VALMCNT+1,^TMP("BKMVPG",$J,VALMCNT,0)=$$PAD^BKMIXX4("","<"," ",BKMIND)_BKMHDRT

 S BKMTOTLN=0

 F  S BKMTOTLN=$O(^UTILITY($J,"W",6,BKMTOTLN)) Q:'BKMTOTLN  D

 . S VALMCNT=VALMCNT+1,^TMP("BKMVPG",$J,VALMCNT,0)=$$PAD^BKMIXX4("","<"," ",5)_^UTILITY($J,"W",6,BKMTOTLN,0)

 K ^UTILITY($J,"W")

BKMVPG    ;PRXM/HC/ALA - PROVIDER GUIDELINES LISTMAN ; 06-APR-2006

 +1       ;;2.1;HIV MANAGEMENT SYSTEM;;Feb 07, 2011

EN        ; -- main entry point for BKMV GUIDELINES

 +1        DO EN^VALM("BKMV GUIDELINES")

 +2        QUIT

 +3       ;

HDR       ; -- header code

 +1       ; Report width - 80 columns

           SET WIDTH=80

 +2        SET END="*** END OF REPORT ***"

 +3        KILL VALMHDR

 +4        NEW HDRSTR,DA,IENS,BKMI,BKM,BKMSUB,BKMSUB1,BKMSUB2

 +5        SET BKMI=0

 +6        SET HDRSTR1=" "_$$GET1^DIQ(200,DUZ_",","1","E")

 +7        SET DA=$GET(DUZ(2))

           SET IENS=$$IENS^DILF(.DA)

           SET HDRSTR2=$$GET1^DIQ(4,IENS,.01,"E")

 +8        SET BKMI=BKMI+1

 +9        SET VALMHDR(BKMI)=HDRSTR1_" "_$$PAD^BKMIXX4("","<"," ",(WIDTH-$LENGTH(HDRSTR1))-$LENGTH(HDRSTR2)\2)_HDRSTR2

 +10      ;

 +11      ; Subheaders - parse if too long

 +12       SET (BKMSUB1,BKMSUB2)=""

 +13       SET BKMSUB=$PIECE($GET(^BKM(90453,BKMGL,0)),U)

 +14       IF BKMSUB'=""

               Begin DoDot:1

 +15               SET BKM=$LENGTH(BKMSUB)\2

 +16               IF $EXTRACT(BKMSUB,BKM)=" "

                       SET BKMSUB1=$EXTRACT(BKMSUB,1,BKM)

                       SET BKMSUB2=$EXTRACT(BKMSUB,BKM+1,$LENGTH(BKMSUB))

 +17               IF $LENGTH(BKMSUB)'>50

                       SET BKMSUB1=BKMSUB

                       SET BKMSUB2=""

 +18               IF $LENGTH(BKMSUB)>50

                       Begin DoDot:2

 +19                       FOR BKM=40:1:$LENGTH(BKMSUB)

                               IF $EXTRACT(BKMSUB,BKM)=" "

                                   QUIT

                               Begin DoDot:3

 +20                               IF $EXTRACT(BKMSUB,BKM)=" "

                                       SET BKMSUB1=$EXTRACT(BKMSUB,1,BKM)

                                       SET BKMSUB2=$EXTRACT(BKMSUB,BKM+1,$LENGTH(BKMSUB))

                               End DoDot:3

                       End DoDot:2

 +21               IF BKMSUB1=""

                       SET BKMSUB1=BKMSUB

 +22      ;

 +23               SET BKMI=BKMI+1

 +24               SET VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",$LENGTH(HDRSTR1))_$$PAD^BKMIXX4("","<"," ",(WIDTH-$LENGTH(HDRSTR1))-$LENGTH(BKMSUB1)\2)_BKMSUB1

 +25               IF BKMSUB2'=""

                       Begin DoDot:2

 +26                       SET BKMI=BKMI+1

 +27                       SET VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",WIDTH-$LENGTH(BKMSUB2)\2)_BKMSUB2

                       End DoDot:2

 +28               SET BKMSUB=0

FOR

                       SET BKMSUB=$ORDER(^BKM(90453,BKMGL,4,BKMSUB))

                       IF 'BKMSUB

                           QUIT

                       Begin DoDot:2

 +29                       SET BKMSUB1=$GET(^BKM(90453,BKMGL,4,BKMSUB,0))

 +30                       SET BKMI=BKMI+1

 +31                       SET VALMHDR(BKMI)=$$PAD^BKMIXX4("","<"," ",WIDTH-$LENGTH(BKMSUB1)\2)_BKMSUB1

                       End DoDot:2

               End DoDot:1

 +32       SET HDRSTR=""

           SET $PIECE(HDRSTR,"-",79)=""

 +33       SET BKMI=BKMI+1

 +34       SET VALMHDR(BKMI)=HDRSTR

 +35       QUIT

 +36      ;

INIT      ; -- init variables and list array

 +1        SET VALMCNT=0

           SET WIDTH=80

 +2        DO HNOTE

 +3        DO RSRC

 +4        DO BODY

 +5       ;S VALMCNT=30

 +6        QUIT

 +7       ;

HELP      ; -- help code

 +1        SET X="?"

           DO DISP^XQORM1

           WRITE !!

 +2        QUIT

 +3       ;

EXIT      ; -- exit code

 +1        KILL ^TMP("BKMVPG",$JOB),^UTILITY($JOB,"W")

 +2        DO CLEAN^VALM10

 +3        DO CLEAR^VALM1

 +4        SET VALMBCK="R"

 +5        KILL HDRSTR1,HDRSTR2

 +6        QUIT

 +7       ;

EXPND     ; -- expand code

 +1        QUIT

 +2       ;

HNOTE     ;Header note

 +1        NEW BKMHF,BKMLINE,DIWF,DIWR,DIWL,BKMTOTLN

 +2        KILL ^UTILITY($JOB,"W")

 +3        IF '$DATA(^BKM(90453,BKMGL,3,0))

               QUIT

 +4        SET BKMHF=0

FOR

               SET BKMHF=$ORDER(^BKM(90453,BKMGL,3,BKMHF))

               IF 'BKMHF

                   QUIT

               Begin DoDot:1

 +5                IF $PIECE(^BKM(90453,BKMGL,3,BKMHF,0),U)'="H"

                       QUIT

 +6                SET DIWF="I6"

                   SET DIWR=75

                   SET DIWL=6

 +7                SET BKMLINE=0

FOR

                       SET BKMLINE=$ORDER(^BKM(90453,BKMGL,3,BKMHF,1,BKMLINE))

                       IF 'BKMLINE

                           QUIT

                       Begin DoDot:2

 +8                        SET X=^BKM(90453,BKMGL,3,BKMHF,1,BKMLINE,0)

                           DO ^DIWP

                       End DoDot:2

               End DoDot:1

 +9        SET BKMTOTLN=0

 +10       FOR

               SET BKMTOTLN=$ORDER(^UTILITY($JOB,"W",6,BKMTOTLN))

               IF 'BKMTOTLN

                   QUIT

               Begin DoDot:1

 +11               SET VALMCNT=VALMCNT+1

                   SET ^TMP("BKMVPG",$JOB,VALMCNT,0)=^UTILITY($JOB,"W",6,BKMTOTLN,0)

               End DoDot:1

 +12       KILL ^UTILITY($JOB,"W")

 +13       QUIT

 +14      ;

RSRC      ;Resources print

 +1        NEW BKMR,BKMRP

 +2        KILL ^UTILITY($JOB,"W")

 +3        IF '$DATA(^BKM(90453,BKMGL,1,0))

               QUIT

 +4        SET BKMR=0

FOR

               SET BKMR=$ORDER(^BKM(90453,BKMGL,1,BKMR))

               IF 'BKMR

                   QUIT

               Begin DoDot:1

 +5                SET DIWF="N"

                   SET DIWR=80

                   SET DIWL=0

 +6                SET X=^BKM(90453,BKMGL,1,BKMR,0)

 +7                SET X=$$PAD^BKMIXX4("","<"," ",WIDTH-$LENGTH(X)\2)_X

                   DO ^DIWP

               End DoDot:1

 +8        SET BKMTOTLN=0

 +9        FOR

               SET BKMTOTLN=$ORDER(^UTILITY($JOB,"W",0,BKMTOTLN))

               IF 'BKMTOTLN

                   QUIT

               Begin DoDot:1

 +10               SET VALMCNT=VALMCNT+1

                   SET ^TMP("BKMVPG",$JOB,VALMCNT,0)=^UTILITY($JOB,"W",0,BKMTOTLN,0)

               End DoDot:1

 +11       KILL ^UTILITY($JOB,"W")

 +12       QUIT

 +13      ;

BODY      ;  BODY OF GUIDELINES

 +1        NEW BKMAC,BKMEN,BKMENHDR,BKMINDNT,BKMNWPG,BKMFIRSC

 +2        SET BKMAC=0

FOR

               SET BKMAC=$ORDER(^BKM(90453,BKMGL,2,"AC",BKMAC))

               IF 'BKMAC

                   QUIT

               Begin DoDot:1

 +3                SET BKMEN=$ORDER(^BKM(90453,BKMGL,2,"AC",BKMAC,0))

 +4                SET BKMENHDR=$PIECE(^BKM(90453,BKMGL,2,BKMEN,0),U,1)

 +5                SET BKMINDNT=$PIECE(^BKM(90453,BKMGL,2,BKMEN,0),U,2)*2

 +6       ; Build ^UTILITY($J,"W") here

 +7                DO BFORM(BKMINDNT,BKMENHDR)

               End DoDot:1

 +8        QUIT

 +9       ;

BFORM(BKMIND,BKMHDRT) ;PRINT TEXT BODY

 +1        NEW BKMLINE,X,Y,BKMTOTLN,BKMI

 +2        KILL ^UTILITY($JOB,"W")

 +3        SET DIWF="N"

           SET DIWR=77

           SET DIWL=6

 +4        SET BKMLINE=0

FOR

               SET BKMLINE=$ORDER(^BKM(90453,BKMGL,2,BKMEN,1,BKMLINE))

               IF 'BKMLINE

                   QUIT

               Begin DoDot:1

 +5                SET X=^BKM(90453,BKMGL,2,BKMEN,1,BKMLINE,0)

                   DO ^DIWP

               End DoDot:1

 +6        SET VALMCNT=VALMCNT+1

           SET ^TMP("BKMVPG",$JOB,VALMCNT,0)=$$PAD^BKMIXX4("","<"," ",BKMIND)_BKMHDRT

 +7        SET BKMTOTLN=0

 +8        FOR

               SET BKMTOTLN=$ORDER(^UTILITY($JOB,"W",6,BKMTOTLN))

               IF 'BKMTOTLN

                   QUIT

               Begin DoDot:1

 +9                SET VALMCNT=VALMCNT+1

                   SET ^TMP("BKMVPG",$JOB,VALMCNT,0)=$$PAD^BKMIXX4("","<"," ",5)_^UTILITY($JOB,"W",6,BKMTOTLN,0)

               End DoDot:1

 +10       KILL ^UTILITY($JOB,"W")

 +11       QUIT

BKMVPG.m