Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSBOCM

PSBOCM.m

Go to the documentation of this file.
  1. PSBOCM ;BIRMINGHAM/TEJ-OVERSHEET MEDICATION OVERVIEW REPORT ;03/06/16 3:06pm
  1. ;;3.0;BAR CODE MED ADMIN;**32,50,68,70,83,139**;Mar 2004;Build 1
  1. ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
  1. ;
  1. ; Reference/IA
  1. ; File 4/10090
  1. ; File 200/10060
  1. ; GETSIOPI^PSJBCMA5/5763
  1. ;
  1. ;*68 - allow SIOPI builder to accomodate more than 1 line in SI array
  1. ;*70 - pass global var PSBCLINORD when Rpc Psbcsutl is called again
  1. ; - add clinic name to new array PSBCLIN to track clinic name per
  1. ; order for printed output.
  1. ; - 1512: Don't show the Special Instructions / Other Print Info
  1. ; unless radio button selected.
  1. ; - convert date/time fields to date only for CO and admin window
  1. ; to 7 days +/-.
  1. ;*83 - add Removes as new event for Next Action column:
  1. ; Remove date@time
  1. ; Missed date@time
  1. ; (Remove)
  1. ;*139 - Prevent null subscript error when variable PSBNXTX2 (for the next
  1. ; administration time) is never reset to a value.
  1. ;
  1. EN ;
  1. N PSBX1X,RESULTS,RESULT,PSBFUTR,QQ,PSBCLIN,PSBSRCHL,STRTDT,STOPDT,EXPIREHDG,REMOV,PSBNXTX,PSBNXTX1,PSBNXTX2 ;*83
  1. S PSBFUTR=$TR(PSBRPT(1),"~","^")
  1. S (PSBOCRIT,PSBXFLG,PSBCFLG)="" ; Order Status search criteria - "A"ctive, "D"C ed, "E"xpired"
  1. S:$P(PSBFUTR,U,7) PSBOCRIT=PSBOCRIT_"D" S:$P(PSBFUTR,U,8) PSBOCRIT=PSBOCRIT_"E" S:$P(PSBFUTR,U,5) PSBOCRIT=PSBOCRIT_"A"
  1. S:$P(PSBFUTR,U,4) PSBOCRIT=PSBOCRIT_"F"
  1. S:$P(PSBFUTR,U,11) PSBXFLG=1
  1. I $D(PSBRPT(.2)) I $P(PSBRPT(.2),U,8) S PSBCFLG=1
  1. S PSBCLINORD=$S($P($G(PSBRPT(4)),U,2)="C":1,1:0) ;*70
  1. ;add ability to use a different heading for expired IM/CO meds ;*70
  1. S EXPIREHDG=$S(PSBCLINORD:"EXPIRED/DC'd within last 7 days",1:"EXPIRED/DC'd")
  1. ;
  1. S PSBFUTR=$TR(PSBRPT(1),"~",U)
  1. ;check Clinic search list ;*70
  1. S PSBSRCHL=$$SRCHLIST^PSBOHDR()
  1. D:$P(PSBRPT(4),U,2)="C"
  1. .S:PSBSRCHL="" PSBSRCHL="All Clinics"
  1. .S PSBSRCHL="Clinic Search List: "_PSBSRCHL
  1. ;
  1. K PSBSRTBY,PSBCMT,PSBADM,PSBDATA,PSBOUTP,PSBLGD,PSBHDR,PSBSTS
  1. S PSBSORT=1
  1. D NOW^%DTC S (Y,PSBNOWX)=% D DD^%DT S PSBDTTM=$E(Y,1,18)
  1. D GETPAR^PSBPAR("ALL","PSB ADMIN BEFORE")
  1. S PSBB4=0 S:RESULTS(0)>0 PSBB4=+RESULTS(0)
  1. D GETPAR^PSBPAR("ALL","PSB ADMIN AFTER")
  1. S PSBAFT=0 S:RESULTS(0)>0 PSBAFT=+RESULTS(0)
  1. ;change admin window times to 7 days for CO
  1. I PSBCLINORD S (PSBB4,PSBAFT)=7
  1. K ^XTMP("PSBO",$J,"PSBLIST")
  1. S (PSBPGNUM,PSBLNTOT,PSBTOT,PSBX1X)=""
  1. K PSBLIST,PSBLIST2
  1. S PSBXDFN=$P(PSBRPT(.1),U,2)
  1. S PSBLIST(PSBXDFN)=""
  1. S (PSBX1X,PSBTOT)=0
  1. F S PSBX1X=$O(PSBLIST(PSBX1X)) Q:+PSBX1X=0 D
  1. .D RPC^PSBCSUTL(.PSBAREA,PSBX1X,,,PSBCLINORD) ;*70
  1. .M PSBDATA=@PSBAREA
  1. .D GETREMOV^PSBO1(PSBXDFN) ;get all removes for this patient *83
  1. .S PSBX2X=1
  1. .S PSBLIST2("ACTIVE")=0,PSBLIST2("FUTURE")=0,PSBLIST2(EXPIREHDG)=0,PSBLIST2(" * ERROR * ")=0
  1. .F S PSBX2X=$O(PSBDATA(PSBX2X)) Q:+PSBX2X=0 D
  1. ..S PSBDATA=PSBDATA(PSBX2X)
  1. ..I $P(PSBDATA,U)="ORD" D Q
  1. ...K PSBDRUGN
  1. ...S PSBORDN=$P(PSBDATA,U,3)
  1. ...S PSBCLIN(PSBORDN)=$S($P(PSBDATA,U,32)]"":"Location: ",1:"")_$P(PSBDATA,U,32) ;*70
  1. ...S PSBTB=$P(PSBDATA,U,29) S PSBTB=$S(PSBTB=1:"UD",PSBTB=2:"IVPB",PSBTB=3:"IV",1:" * ERROR * ")
  1. ...S PSBTB(PSBORDN,PSBTB)=""
  1. ...S PSBSTS=$P(PSBDATA,U,23) S PSBSTS=$S((PSBSTS="A")&(($P(PSBDATA,U,27)>PSBNOWX)):"Active",PSBSTS="H":"On Hold",PSBSTS="D":"Discontinued",PSBSTS="DE":"Discontinued (Edit)",(PSBSTS="E")!($P(PSBDATA,U,27)'>PSBNOWX):"Expired",1:" * ERROR * ")
  1. ...S PSBSTS(PSBORDN,PSBSTS)=""
  1. ...S STRTDT=$P(PSBDATA,U,22),STOPDT=$P(PSBDATA,U,27) ;*70
  1. ...S PSBSTSX=$S(STOPDT'>PSBNOWX:EXPIREHDG,$$FMADD^XLFDT(STRTDT,,,-PSBB4)'>PSBNOWX:"ACTIVE",STRTDT>$$FMADD^XLFDT(PSBNOWX,,,PSBB4):"FUTURE",1:" * ERROR * ") ;*70
  1. ...;
  1. ...S PSBLIST2(PSBSTSX,$P(PSBDATA,U,9),PSBORDN)="" S PSBLIST2(PSBSTSX)=PSBLIST2(PSBSTSX)+1
  1. ...S:PSBOCRIT[$E(PSBSTSX,1) PSBTOT=PSBTOT+1
  1. ...S PSBSCHTY=$P(PSBDATA,U,6)
  1. ...I PSBTB="IV" S PSBSCHTY=" "
  1. ...S PSBSCHTY(PSBORDN,PSBSCHTY)=""
  1. ...S PSBDOSR=$P(PSBDATA,U,10)_", "_$P(PSBDATA,U,11)
  1. ...S PSBDOSR=$TR($E(PSBDOSR,1)," ")_$E(PSBDOSR,2,999)
  1. ...S PSBDOSR(PSBORDN,PSBDOSR)="" K PSBOMDR(PSBORDN)
  1. ...S PSBSCHD=$P(PSBDATA,U,7) I PSBSCHD="" S PSBSCHD=" "
  1. ...S PSBSCHD(PSBORDN,PSBSCHD)=""
  1. ...S PSBNXTX1=$$NEXTADM^PSBCSUTX(PSBX1X,PSBORDN)
  1. ...S PSBNXTX2="" ;init *83
  1. ...I PSBSTS["Hold" S PSBNXTX2="Provider Hold"
  1. ...;
  1. ...;Next admin date triggers data for Next Action col, and also *83
  1. ...; if a remove action is pending use that text for NA col. *83
  1. ...S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
  1. ...I PSBSTS'["Hold",((PSBNXTX1)!(REMOV)) D
  1. ....;build Admin Next Action text
  1. ....D:PSBNXTX1
  1. .....S NXTADM=$$FMADD^XLFDT(PSBNXTX1,,,PSBAFT)
  1. .....S PSBNXTX2=$S(PSBNOWX>NXTADM:"MISSED ",1:"DUE ")_PSBNXTX1
  1. ....;Removal tests and Next Action text build *83
  1. ....S REMOV=$O(^TMP("PSB",$J,"RM","B",PSBORDN,0))
  1. ....D:REMOV
  1. .....S MRR=$P(PSBDATA(PSBX2X),U,35)
  1. .....S RMVTIM=$P(^TMP("PSB",$J,"RM",REMOV),U)
  1. .....;Sched types below have no admin nor removal times, but do know
  1. .....; this MRR was given and next is Removal
  1. .....I ("^P^OC^"[("^"_PSBSCHTY_"^")) S:PSBSTS'["Hold" PSBNXTX2="(Removal)" Q
  1. .....;sys err tst, sched rmv dt/tm empty, if null use nxt adm for rmv
  1. .....I MRR=1,'RMVTIM S RMVTIM=PSBNXTX1
  1. .....I PSBNOWX>$$FMADD^XLFDT(RMVTIM,,,PSBAFT) D ;missed rm
  1. ......S PSBNXTX2="MISSED "_RMVTIM_" (Removal)"
  1. ......S:'RMVTIM PSBNXTX2="REMOVE" ;err, rmv empty
  1. .....E D ;due rm
  1. ......S PSBNXTX2="REMOVE "_RMVTIM
  1. .....K MRR,NXTADM,RMVTIM
  1. ...;
  1. ...S PSBNXTX1=$$FMTDT^PSBOCE1(PSBNXTX1)
  1. ...;don't do if Expired Next action is a Removal *83
  1. ...I PSBNXTX2'["Removal",PSBNXTX2'["REMOVE" D
  1. ....I ("^P^OC^O"[("^"_PSBSCHTY))!(PSBTB="IV")!(PSBSTS["Discontinued")!(PSBSTS["Expired") S:PSBSTS'["Hold" PSBNXTX2=" "
  1. ...S:PSBNXTX2="" PSBNXTX2=" " ; *139
  1. ...S PSBNXTX(PSBORDN,PSBNXTX2)=""
  1. ...; ** SPECIAL INSTRUCTIONS **
  1. ...S PSBX2X=PSBX2X+1
  1. ...; *68
  1. ...K ^TMP("PSJBCMA5",$J)
  1. ...I PSBSIFLG D GETSIOPI^PSJBCMA5(PSBX1X,PSBORDN,1)
  1. ...F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)) Q:'QQ D
  1. ....S PSBSI(PSBORDN,QQ)=^TMP("PSJBCMA5",$J,PSBX1X,PSBORDN,QQ)
  1. ...; *68 end
  1. ...S PSBOSTDT=$P(PSBDATA,U,22)
  1. ...S PSBOSTDT(PSBORDN,PSBOSTDT)=""
  1. ...S PSBOSPDT=$P(PSBDATA,U,27)
  1. ...S PSBOSPDT(PSBORDN,PSBOSPDT)=""
  1. ..I "^DD^ADD^SOL"[(U_$P(PSBDATA(PSBX2X),U)) D Q
  1. ...F I=PSBX2X:1 S PSBDATA1=PSBDATA(I) D Q:$D(PSBOMDR(PSBORDN))
  1. ....I "^DD^ADD^SOL"[(U_$P(PSBDATA1,U)) S PSBX2X=I S PSBDRUGN=$G(PSBDRUGN,"")_$P(PSBDATA1,U,3)_", " Q
  1. ....S $E(PSBDRUGN,$L(PSBDRUGN)-1)="" S PSBDRUGN(PSBORDN,$E(PSBDRUGN,1,250))=PSBDRUGN
  1. ....S PSBOMDR(PSBORDN,$E((PSBDRUGN_"; "_PSBDOSR),1,250))=PSBDRUGN_"; "_PSBDOSR
  1. ..I $P(PSBDATA,U)="END" Q
  1. ..I $P(PSBDATA(PSBX2X),U)="ORF" D Q
  1. ...S PSBDATA=PSBDATA(PSBX2X)
  1. ...S:$P(PSBDATA,U,2)]"" PSBFLGD(PSBORDN,$P(PSBDATA,U,3)_" - "_$P(PSBDATA,U,4))=""
  1. ..I ($P(PSBDATA,U)="ADM")&($P(PSBDATA,U,4)]"") D
  1. ...S PSBXID=$P(PSBDATA,U,6)_U_$P(PSBDATA,U,4),PSBADM(PSBORDN,(-1*($P(PSBDATA,U,6))),PSBXID)=PSBDATA
  1. ...S PSBTEST="" F S PSBTEST=$O(PSBFLGD(PSBORDN,PSBTEST)) Q:PSBTEST="" I $P(PSBTEST,":")="NOX" K PSBFLGD(PSBORDN,PSBTEST) Q
  1. ...I $O(PSBSCHTY(PSBORDN,""))="P" S PSBPRNR(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,9)
  1. ...I $P(PSBDATA,U,3)]"" S PSBBID(PSBORDN,$P(PSBDATA,U,4))=$P(PSBDATA,U,3)
  1. ...S:PSBXFLG PSBLGD(PSBORDN,"X","INITIALS",$P(PSBDATA,U,8))=""
  1. ...K PSBDATA(PSBX2X)
  1. ...I ($P(PSBDATA(PSBX2X+1),U)="CMT") F S PSBDATA=PSBDATA(PSBX2X+1) Q:($P(PSBDATA,U)'="CMT") D
  1. ....S PSBX2X=PSBX2X+1
  1. ....S PSBDATA=PSBDATA(PSBX2X)
  1. ....K PSBDATA(PSBX2X)
  1. ....S:$P(PSBDATA,U,3)]"" PSBPRNEF(PSBORDN,$P(PSBXID,U,2))=$P(PSBDATA,U,3)
  1. ....I 'PSBCFLG S PSBDATA=PSBDATA(PSBX2X+1) Q
  1. ....I $P(PSBDATA,U,2)'="" D
  1. .....S PSBLGD(PSBORDN,"C","INITIALS",$P(PSBDATA,U,4))=""
  1. .....S PSBCMT(PSBORDN,$P(PSBXID,U,2),(-1*$P(PSBDATA,U,6)),PSBX2X)=PSBDATA
  1. I +PSBTOT=0 K PSBLIST,^XTMP("PSBO",$J,"PSBLIST")
  1. D CREATHDR^PSBOCM1
  1. D SUBHDR^PSBOCE
  1. D BLDRPT
  1. D WRTRPT^PSBOCM1
  1. K ^TMP("PSJBCMA5",$J) ;*68
  1. Q
  1. BLDRPT ; Build REPORT DATA
  1. S PSBTOPHD=PSBLNTOT-2
  1. K PSBL2ULN
  1. I '$D(PSBLIST2) D Q
  1. .S PSBOUTP(0,PSBLNTOT)="W !!,""<<<< NO ORDERS TO DISPLAY >>>>"",!!"
  1. S PSBMORE=5 F PSBX1X="ACTIVE","FUTURE",EXPIREHDG," * ERROR * " D
  1. .I PSBX1X'=" * ERROR * " S PSBSUM=PSBX1X_" ["_PSBLIST2(PSBX1X)_$S(PSBLIST2(PSBX1X)=1:" Order",1:" Orders")_"]" S PSBOUTP($$PGTOT,PSBLNTOT)="W !!,"""_PSBSUM_""""
  1. .Q:PSBLIST2(PSBX1X)=0
  1. .Q:PSBOCRIT'[$E(PSBX1X,1)
  1. .S:$L(PSBSUM)>$G(PSBL2ULN,0) PSBL2ULN=$L(PSBSUM)
  1. .S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBL2ULN),"" "",""=""),!"
  1. .S PSBOUTP($$PGTOT,PSBLNTOT)="W !"
  1. .K PSBDATA
  1. .S X0="",PSBTOT1=0
  1. .F S X0=$O(PSBLIST2(PSBX1X,X0)) Q:X0="" S PSBX2X="" F S PSBX2X=$O(PSBLIST2(PSBX1X,X0,PSBX2X)) Q:PSBX2X="" D
  1. ..M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"X","INITIALS") M PSBLGD("INITIALS")=PSBLGD(PSBX2X,"C","INITIALS")
  1. ..S PSBDATA(1,1)=$O(PSBTB(PSBX2X,""))
  1. ..S PSBDATA(1,2)=$O(PSBSTS(PSBX2X,""))
  1. ..S PSBDATA(1,3)=$O(PSBSCHTY(PSBX2X,""))
  1. ..S Y0=$O(PSBOMDR(PSBX2X,"")) I Y0]"" S PSBDATA(1,4)="("_X0_")",PSBDATA(1,4,0)=PSBOMDR(PSBX2X,Y0)
  1. ..S PSBDATA(1,5)=$O(PSBSCHD(PSBX2X,""))
  1. ..S PSBDATA(1,6)=$O(PSBNXTX(PSBX2X,""))
  1. ..S:PSBDATA(1,6)'["Hold" $P(PSBDATA(1,6)," ",2)=$$FMTDT^PSBOCE1($P(PSBDATA(1,6)," ",2))
  1. ..S PSBDATA(1,7)=$$FMTDT^PSBOCE1($O(PSBOSTDT(PSBX2X,"")))
  1. ..S PSBDATA(1,8)=$$FMTDT^PSBOCE1($E($O(PSBOSPDT(PSBX2X,"")),1,12))
  1. ..K PSBSIDAT M PSBSIDAT=PSBSI(PSBX2X) ;*68
  1. ..S PSBTOT1=PSBTOT1+1
  1. ..K PSBDATA(2),PSBDATA(3),PSBSILN
  1. ..D BUILDLN^PSBOCM1,SIOPI(.PSBSIDAT,PSBTAB8,$S(PSBX2X["V":"Other Print Info: ",1:""))
  1. ..I $D(PSBRPLN) S PSBMORE=$O(PSBRPLN(""),-1)+6 I $D(PSBSILN) S PSBMORE=PSBMORE+$O(PSBSILN(""),-1)
  1. ..K PSB1,X I $D(PSBFLGD(PSBX2X)) S PSB="" F S PSB=$O(PSBFLGD(PSBX2X,PSB)) Q:PSB="" I ($P(PSB,":")'="NOX")&($P(PSB,":")'="STAT") S PSB1=$G(PSB1,"")_PSB
  1. ..;*70 build write clinic stmt
  1. ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_$G(PSBCLIN(PSBX2X))_""""_",!"
  1. ..S PSBCNT=PSBTOT1_" "_$G(PSB1,"")
  1. ..S PSBOUTP($$PGTOT,PSBLNTOT)="W """_PSBCNT_""""
  1. ..S I="" F S I=$O(PSBRPLN(I)) Q:+I=0 D
  1. ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBRPLN(I)_""""
  1. ..S I="" F S I=$O(PSBSILN(I)) Q:+I=0 D
  1. ...S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_PSBSILN(I)_""""
  1. ..S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,$TR($J("""",PSBTAB8),"" "",""-""),!"
  1. ..K PSBRPLN,PSBDATA,PSBSILN
  1. D:+PSBTOT>0 LGD
  1. Q
  1. PGTOT(X) ;mnt PAGE Number
  1. I (PSBLNTOT+PSBMORE)>(IOSL) D PGC^PSBOCE1
  1. I $G(X,1) S PSBLNTOT=PSBLNTOT+$G(X,1),PSBMORE=PSBMORE-$G(X,1)
  1. Q PSBPGNUM
  1. SIOPI(PSBXSI,TAB,Y) ;create SIOPI text
  1. ; *68 - modified this tag to handle only WP extra lines
  1. I '$P(PSBRPT(4),U) Q ;[*70-1512]
  1. Q:$O(PSBXSI(""))=""
  1. ;
  1. N X,LBL,LBLLN,RMAR,TXT
  1. I $G(Y)="" S Y="Special Instructions: "
  1. ; build label for SI field, then check $L to make a right margin
  1. S LBL=" "_Y
  1. S LBLLN=$L(LBL),RMAR="",$P(RMAR," ",LBLLN+1)="" ;make margin of " "
  1. K J,TXT,TXT1,TXT2 S J(0)=""
  1. S J=($O(J(""),-1)+1) S PSBSILN(J)="",J(J)="" S J=($O(J(""),-1)+1)
  1. F X=0:0 S X=$O(PSBXSI(X)) Q:'X D
  1. .I X=1 S TXT=LBL_PSBXSI(X) ;put label & 1st line together
  1. .E S TXT=RMAR_PSBXSI(X) ;all other lines add rmar
  1. .S TXT1=TXT
  1. .I ($L(TXT1)>0),$F(TXT1,"""")>1 D
  1. ..S TXT1=$TR(TXT1,"""","^")
  1. ..I $L(TXT1)+5'<TAB S TXT2=$E(TXT1,TAB-9,999),TXT1=$E(TXT1,1,TAB-10)
  1. ..I $L(TXT1,"^")>1 F Y=1:1:$L(TXT1,"^")-1 S $P(TXT1,"^",Y)=$P(TXT1,"^",Y)_""""
  1. ..I $D(TXT2) I $L(TXT2,"^")>1 F X=1:1:$L(TXT2,"^")-1 S $P(TXT2,"^",X)=$P(TXT2,"^",X)_""""
  1. ..S TXT1=$TR(TXT1,"^","""") I $D(TXT2) S TXT2=$TR(TXT2,"^","""")
  1. .S $E(PSBSILN(J),5,999)=TXT1,J(J)="",J=J+1
  1. .I $D(TXT2) S $E(PSBSILN(J),5,999)=TXT2,J(J)="",J=J+1
  1. S $E(PSBSILN(J),3,999)=" ",J(J)="",J=J+1
  1. Q
  1. LGD ; Create Report's Legend
  1. K PSBLGDO
  1. S PSBLGD("ORDER TYPES","C")="Continuous"
  1. S PSBLGD("ORDER TYPES","O")="One Time"
  1. S PSBLGD("ORDER TYPES","OC")="On Call"
  1. S PSBLGD("ORDER TYPES","P")="PRN"
  1. S PSB=0 F S PSB=$O(PSBLGD("INITIALS",PSB)) Q:+PSB=0 D
  1. .S PSBINIT=$$GET1^DIQ(200,PSB_",","INITIAL"),PSBLGD("INITIALS",$S(PSBINIT']" ":"*n/a*",1:PSBINIT))=$$GET1^DIQ(200,PSB_",","NAME")
  1. .K PSBLGD("INITIALS",PSB)
  1. S PSBPGNUM=$O(PSBOUTP(""),-1),PSBLGDO(0)="REPORT LEGEND"
  1. S PSBLGDO(1)=""
  1. S PSBLGDO(2)=$S($G(PSBNO,0):"",1:"SCHEDULE TYPES")
  1. S PSBLGDO(3)=""
  1. I '$G(PSBNO,0) S X1="",X2=3 F S X1=$O(PSBLGD("ORDER TYPES",X1)) Q:X1="" S X2=X2+1,PSBLGDO(X2)=X1,$E(PSBLGDO(X2),5)="- "_PSBLGD("ORDER TYPES",X1)
  1. I $D(PSBLGD("INITIALS")) S $E(PSBLGDO(2),35)="INITIALS" S X1="",X2=3 F S X1=$O(PSBLGD("INITIALS",X1)) Q:X1="" S X2=X2+1,$E(PSBLGDO(X2),35)=X1,$E(PSBLGDO(X2),40)="- "_PSBLGD("INITIALS",X1)
  1. S (PSBMORE,X0)=10+($O(PSBLGDO(""),-1))
  1. I (PSBLNTOT+PSBMORE)'<IOSL S PSBLNTOT=PSBTOPHD-2,PSBPGNUM=PSBPGNUM+1
  1. I IOSL<1000 S X2=PSBLNTOT F Q:X2'<(IOSL-(X0+3)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !",X2=X2+1
  1. S PSBMORE=X0
  1. S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
  1. F X1=0:1 Q:'$D(PSBLGDO(X1)) S PSBOUTP($$PGTOT,PSBLNTOT)="W !,"""_$G(PSBLGDO(X1)," ")_""""
  1. S PSBOUTP($$PGTOT(2),PSBLNTOT)="W !,"""_$TR($J("",IOM)," ","=")_""",!"
  1. Q