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")
Q
;
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
Q
;
INIT ; -- init variables and list array
S VALMCNT=0,WIDTH=80
D HNOTE
D RSRC
D BODY
;S VALMCNT=30
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("BKMVPG",$J),^UTILITY($J,"W")
D CLEAN^VALM10
D CLEAR^VALM1
S VALMBCK="R"
K HDRSTR1,HDRSTR2
Q
;
EXPND ; -- expand code
Q
;
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")
Q
;
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")
Q
;
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)
Q
;
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")
Q
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
