ORLPR0 ; SLC/CLA - Report formatter for patient lists ;11/27/91 [3/22/00 12:41pm]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**47**;Dec 17, 1997
;
OUTPUT ;called by TaskMan via ORUTL1 (ORUTL1 queued output was setup by INQ)
; SLC/PKS - Modified 8/99.
U IO
N ORTDATA,ORTDEV,ORTCREAT,ORTSUB,ORTTYPE
S (PR,PF,PAGE)=1,ORLOUT="",ORTIT=$S(TL="TA":"Team Patient Autolinked List",TL="TM":"Team Patient Manual List",TL="MRAL":"Team Patient Manual Removal/Autolinked List",1:"Personal Patient List"),ORTIT(1)=$P(ORLIST,U,2)
S:$E(IOST,1,2)'="C-" ORSNUM=1 D HEADING K ORSNUM
S ORTDATA=^OR(100.21,+ORLIST,0) ; Get 0-node data.
S ORTDEV=$P(ORTDATA,U,4) ; Assign "device."
I ORTDEV'="" D ; "Device" exist?
. S ORTDEV=$$GET1^DIQ(3.5,+($G(ORTDEV)),.01) ; Get device name.
S ORTCREAT=$P(ORTDATA,U,5) ; Assign "creator."
I ORTCREAT'="" D ; "Creator" exist?
. S ORTCREAT=$P($G(^VA(200,ORTCREAT,0)),U) ; Get creator's name.
S ORTTYPE=$P(ORTDATA,U,2) ; Assign type.
I ORTTYPE'="" D TYPESTR ; Full type string.
S ORTSUB="" ; Initialize.
I TL["A" D ; A/L type?
. S ORTSUB=$P(ORTDATA,U,6) ; Assign "subcribe."
. I ORTSUB="" S ORTSUB="NO" ; Default for no data.
. I ORTSUB="Y" S ORTSUB="YES" ; Full word.
; Put in a blank line if no device, creator, type, or subscribe info:
I (ORTDEV'="")!(ORTCREAT'="")!(ORTTYPE'="")!(ORTSUB'="") W !
I ORTCREAT'="" W !," Creator: "_ORTCREAT ; Write creator line.
I ORTDEV'="" W !," Device: "_ORTDEV ; Write device line.
I ORTTYPE'="" W !," Type: "_ORTTYPE ; Write type line.
I TL["A" W !," Subscribable: "_ORTSUB ; Subscribe line.
S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,1,ORI)) Q:ORI<1 S USER=^(ORI,0) D
. S ^TMP("ORLP",$J,"LIST","B",$P(^VA(200,+USER,0),"^"))=""
D USER
I TL["A",$O(^OR(100.21,+ORLIST,2,0)) S PR=1 D D ALINK
. N VP,OROK
. S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,2,ORI)) Q:'ORI D
.. S VP=^(ORI,0),VP(1)="^"_$P($P(VP,";",2),U),VP(2)=+VP I $L(VP,"^")=2 S VP(3)=$S($P(VP,U,2)="A":"Attending",$P(VP,U,2)="P":"Primary",1:"Primary or Attending")
.. S OROK=0
.. I VP(1)["DIC(42," S OROK=1,VPNM="Ward......."_$P(@(VP(1)_VP(2)_",0)"),U)
.. I VP(1)["VA(200," S OROK=1,VPNM="Provider..."_$P(@(VP(1)_VP(2)_",0)"),U)_" - as "_VP(3)
.. I VP(1)["DIC(45.7," S OROK=1,VPNM="Specialty.."_$P(@(VP(1)_VP(2)_",0)"),U)
.. I VP(1)["DG(405.4," S OROK=1,VPNM="Room/Bed..."_$P(@(VP(1)_VP(2)_",0)"),U)
.. I VP(1)["SC" S OROK=1,VPNM="Clinic....."_$P(@(VP(1)_VP(2)_",0)"),U)
.. I 'OROK S VPNM="(Undetermined) - "_$P(@(VP(1)_VP(2)_",0)"),U)
.. S ^TMP("ORLP",$J,"LIST","AL",VPNM)=""
S ORI=0 F S ORI=$O(^OR(100.21,+ORLIST,10,ORI)) Q:ORI<1 D
. N VAERR,VAIN,DFN
. S PAT=^OR(100.21,+ORLIST,10,ORI,0),DFN=+PAT,PAT=^DPT(DFN,0)
. D INP^VADPT Q:VAERR S WRD=$S(VAIN(4):$E($P(VAIN(4),U,2),1,10),1:"WD-none"),RMBED=$S(VAIN(5)]"":VAIN(5),1:"unassigned"),SSN=$E($P(PAT,U,9),6,9)_"0000",PATNM=$P(PAT,U)
. I SORT="T" S ^TMP("ORLP",$J,"LIST","C","A"_$E(SSN,1,4),PATNM,WRD_": "_RMBED)="" Q
. I SORT="R" S ^TMP("ORLP",$J,"LIST","C",WRD_": "_RMBED,PATNM,$E(SSN,1,4))="" Q
. S ^TMP("ORLP",$J,"LIST","C",$P(PAT,"^"),$E(SSN,1,4),WRD_": "_RMBED)=""
D PT
I ORLOUT'["^" W !!?5,"List completed." D
. I $E(IOST)="C" S DIR(0)="E" D ^DIR
I $D(ZTQUEUED) S ZTREQ="@"
END ;called by INQ, flow thru from OUTPUT
K ALINK,DIR,L,LINE,ORI,ORLOUT,ORTIT,PAGE,PAT,PATNM,PF,PR,PT,PTRB,PTSSN,RMBED,SSN,USER,VPNM,WRD,X1,X2,X3,Y,%ZIS,ZTDESC,ZTRTN,ZTSAVE
K ^TMP("ORLP",$J,"LIST")
Q
;
HEADING ;called by OUTPUT, USER, PT - build list heading & handle paging
Q:ORLOUT["^"
I $$S^%ZTLOAD S ORLOUT="^",ZTSTOP=1 Q
I PAGE>1,($E(IOST)="C") S DIR(0)="E" D ^DIR I Y<1 S ORLOUT="^" Q
W:'$D(ORSNUM) @IOF
W !,$P($$HTE^XLFDT($H),"@"),?(IOM-$L(ORTIT)/2),ORTIT,?70,"page ",PAGE
W !?(IOM-$L(ORTIT(1))/2),ORTIT(1) W !?(IOM-$L(ORTIT(1))/2)-2 F L=0:1 W "=" Q:L=($L(ORTIT(1))+4)
S (PR,PF)=1,PAGE=PAGE+1
Q
ALINK ;called by OUTPUT - build entries (autolinks)
S ALINK="" F S ALINK=$O(^TMP("ORLP",$J,"LIST","AL",ALINK)) Q:ALINK="" D
. I $L(ALINK)'<1,($Y+2>IOSL) D HEADING Q:ORLOUT["^"
. I PR=1 W !!," Autolinks: ",ALINK S PR=2
. E W !?16,ALINK
Q
USER ;called by OUTPUT - build list entries (users)
S USER="" F S USER=$O(^TMP("ORLP",$J,"LIST","B",USER)) Q:USER="" D
. I $L(USER)'<1,($Y+2>IOSL) D HEADING Q:ORLOUT["^"
. I PR=1 W !!,"Provider/users: ",USER S PR=2
. E W !?16,USER
Q
PT ;called by OUTPUT - build list entries (patients)
N DOTS,SPACE,WRDL
S $P(DOTS,".",34)="",$P(SPACE," ",28)="",WRDL=""
S X1="" F S X1=$O(^TMP("ORLP",$J,"LIST","C",X1)) Q:X1="" D
. S X2="" F S X2=$O(^TMP("ORLP",$J,"LIST","C",X1,X2)) Q:X2="" D
.. S X3="" F S X3=$O(^TMP("ORLP",$J,"LIST","C",X1,X2,X3)) Q:X3="" D
... ; sort="T" Terminal digit sort
... I SORT="T" S LINE="("_$E(X1,2,5)_") "_$E(X2_DOTS,1,33)_" "_$E(X3_SPACE,1,27) D PT1 Q
... ; sort="R" Room/Bed sort
... I SORT="R" D D PT1 Q
.... I PF=1 S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")" Q
.... I WRDL'=$P(X1,":") S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")" Q
.... S LINE=$E($E(SPACE,1,$L(WRDL)+1)_$P(X1,":",2)_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")"
... ; else sort alpha by patient name
... S LINE=$E(X1_DOTS,1,33)_"("_X2_") "_X3 D PT1
Q
;
PT1 I $L(X1)'<1,($Y+3>IOSL) D HEADING Q:ORLOUT["^"
I SORT="R" S WRDL=$P(X1,":") I PF=1 S LINE=$E(X1_SPACE,1,27)_" "_$E(X2_DOTS,1,33)_" ("_X3_")"
I PF=1 W !!,"Patients: " S PF=2
W !?3,LINE
Q
TYPESTR ; Assign description strings to ORTTYPE (Team List type) variables.
; Tag by PKS - 8/99.
;
I ORTTYPE="P" S ORTTYPE="PERSONAL"
I ORTTYPE="TA" S ORTTYPE="AUTOLINK"
I ORTTYPE="TM" S ORTTYPE="MANUAL"
I ORTTYPE="MRAL" S ORTTYPE="MRAL"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORLPR0 6039 printed Oct 16, 2024@18:32:08 Page 2
ORLPR0 ; SLC/CLA - Report formatter for patient lists ;11/27/91 [3/22/00 12:41pm]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**47**;Dec 17, 1997
+2 ;
OUTPUT ;called by TaskMan via ORUTL1 (ORUTL1 queued output was setup by INQ)
+1 ; SLC/PKS - Modified 8/99.
+2 USE IO
+3 NEW ORTDATA,ORTDEV,ORTCREAT,ORTSUB,ORTTYPE
+4 SET (PR,PF,PAGE)=1
SET ORLOUT=""
SET ORTIT=$SELECT(TL="TA":"Team Patient Autolinked List",TL="TM":"Team Patient Manual List",TL="MRAL":"Team Patient Manual Removal/Autolinked List",1:"Personal Patient List")
SET ORTIT(1)=$PIECE(ORLIST,U,2)
+5 if $EXTRACT(IOST,1,2)'="C-"
SET ORSNUM=1
DO HEADING
KILL ORSNUM
+6 ; Get 0-node data.
SET ORTDATA=^OR(100.21,+ORLIST,0)
+7 ; Assign "device."
SET ORTDEV=$PIECE(ORTDATA,U,4)
+8 ; "Device" exist?
IF ORTDEV'=""
Begin DoDot:1
+9 ; Get device name.
SET ORTDEV=$$GET1^DIQ(3.5,+($GET(ORTDEV)),.01)
End DoDot:1
+10 ; Assign "creator."
SET ORTCREAT=$PIECE(ORTDATA,U,5)
+11 ; "Creator" exist?
IF ORTCREAT'=""
Begin DoDot:1
+12 ; Get creator's name.
SET ORTCREAT=$PIECE($GET(^VA(200,ORTCREAT,0)),U)
End DoDot:1
+13 ; Assign type.
SET ORTTYPE=$PIECE(ORTDATA,U,2)
+14 ; Full type string.
IF ORTTYPE'=""
DO TYPESTR
+15 ; Initialize.
SET ORTSUB=""
+16 ; A/L type?
IF TL["A"
Begin DoDot:1
+17 ; Assign "subcribe."
SET ORTSUB=$PIECE(ORTDATA,U,6)
+18 ; Default for no data.
IF ORTSUB=""
SET ORTSUB="NO"
+19 ; Full word.
IF ORTSUB="Y"
SET ORTSUB="YES"
End DoDot:1
+20 ; Put in a blank line if no device, creator, type, or subscribe info:
+21 IF (ORTDEV'="")!(ORTCREAT'="")!(ORTTYPE'="")!(ORTSUB'="")
WRITE !
+22 ; Write creator line.
IF ORTCREAT'=""
WRITE !," Creator: "_ORTCREAT
+23 ; Write device line.
IF ORTDEV'=""
WRITE !," Device: "_ORTDEV
+24 ; Write type line.
IF ORTTYPE'=""
WRITE !," Type: "_ORTTYPE
+25 ; Subscribe line.
IF TL["A"
WRITE !," Subscribable: "_ORTSUB
+26 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100.21,+ORLIST,1,ORI))
if ORI<1
QUIT
SET USER=^(ORI,0)
Begin DoDot:1
+27 SET ^TMP("ORLP",$JOB,"LIST","B",$PIECE(^VA(200,+USER,0),"^"))=""
End DoDot:1
+28 DO USER
+29 IF TL["A"
IF $ORDER(^OR(100.21,+ORLIST,2,0))
SET PR=1
Begin DoDot:1
+30 NEW VP,OROK
+31 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100.21,+ORLIST,2,ORI))
if 'ORI
QUIT
Begin DoDot:2
+32 SET VP=^(ORI,0)
SET VP(1)="^"_$PIECE($PIECE(VP,";",2),U)
SET VP(2)=+VP
IF $LENGTH(VP,"^")=2
SET VP(3)=$SELECT($PIECE(VP,U,2)="A":"Attending",$PIECE(VP,U,2)="P":"Primary",1:"Primary or Attending")
+33 SET OROK=0
+34 IF VP(1)["DIC(42,"
SET OROK=1
SET VPNM="Ward......."_$PIECE(@(VP(1)_VP(2)_",0)"),U)
+35 IF VP(1)["VA(200,"
SET OROK=1
SET VPNM="Provider..."_$PIECE(@(VP(1)_VP(2)_",0)"),U)_" - as "_VP(3)
+36 IF VP(1)["DIC(45.7,"
SET OROK=1
SET VPNM="Specialty.."_$PIECE(@(VP(1)_VP(2)_",0)"),U)
+37 IF VP(1)["DG(405.4,"
SET OROK=1
SET VPNM="Room/Bed..."_$PIECE(@(VP(1)_VP(2)_",0)"),U)
+38 IF VP(1)["SC"
SET OROK=1
SET VPNM="Clinic....."_$PIECE(@(VP(1)_VP(2)_",0)"),U)
+39 IF 'OROK
SET VPNM="(Undetermined) - "_$PIECE(@(VP(1)_VP(2)_",0)"),U)
+40 SET ^TMP("ORLP",$JOB,"LIST","AL",VPNM)=""
End DoDot:2
End DoDot:1
DO ALINK
+41 SET ORI=0
FOR
SET ORI=$ORDER(^OR(100.21,+ORLIST,10,ORI))
if ORI<1
QUIT
Begin DoDot:1
+42 NEW VAERR,VAIN,DFN
+43 SET PAT=^OR(100.21,+ORLIST,10,ORI,0)
SET DFN=+PAT
SET PAT=^DPT(DFN,0)
+44 DO INP^VADPT
if VAERR
QUIT
SET WRD=$SELECT(VAIN(4):$EXTRACT($PIECE(VAIN(4),U,2),1,10),1:"WD-none")
SET RMBED=$SELECT(VAIN(5)]"":VAIN(5),1:"unassigned")
SET SSN=$EXTRACT($PIECE(PAT,U,9),6,9)_"0000"
SET PATNM=$PIECE(PAT,U)
+45 IF SORT="T"
SET ^TMP("ORLP",$JOB,"LIST","C","A"_$EXTRACT(SSN,1,4),PATNM,WRD_": "_RMBED)=""
QUIT
+46 IF SORT="R"
SET ^TMP("ORLP",$JOB,"LIST","C",WRD_": "_RMBED,PATNM,$EXTRACT(SSN,1,4))=""
QUIT
+47 SET ^TMP("ORLP",$JOB,"LIST","C",$PIECE(PAT,"^"),$EXTRACT(SSN,1,4),WRD_": "_RMBED)=""
End DoDot:1
+48 DO PT
+49 IF ORLOUT'["^"
WRITE !!?5,"List completed."
Begin DoDot:1
+50 IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
End DoDot:1
+51 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
END ;called by INQ, flow thru from OUTPUT
+1 KILL ALINK,DIR,L,LINE,ORI,ORLOUT,ORTIT,PAGE,PAT,PATNM,PF,PR,PT,PTRB,PTSSN,RMBED,SSN,USER,VPNM,WRD,X1,X2,X3,Y,%ZIS,ZTDESC,ZTRTN,ZTSAVE
+2 KILL ^TMP("ORLP",$JOB,"LIST")
+3 QUIT
+4 ;
HEADING ;called by OUTPUT, USER, PT - build list heading & handle paging
+1 if ORLOUT["^"
QUIT
+2 IF $$S^%ZTLOAD
SET ORLOUT="^"
SET ZTSTOP=1
QUIT
+3 IF PAGE>1
IF ($EXTRACT(IOST)="C")
SET DIR(0)="E"
DO ^DIR
IF Y<1
SET ORLOUT="^"
QUIT
+4 if '$DATA(ORSNUM)
WRITE @IOF
+5 WRITE !,$PIECE($$HTE^XLFDT($HOROLOG),"@"),?(IOM-$LENGTH(ORTIT)/2),ORTIT,?70,"page ",PAGE
+6 WRITE !?(IOM-$LENGTH(ORTIT(1))/2),ORTIT(1)
WRITE !?(IOM-$LENGTH(ORTIT(1))/2)-2
FOR L=0:1
WRITE "="
if L=($LENGTH(ORTIT(1))+4)
QUIT
+7 SET (PR,PF)=1
SET PAGE=PAGE+1
+8 QUIT
ALINK ;called by OUTPUT - build entries (autolinks)
+1 SET ALINK=""
FOR
SET ALINK=$ORDER(^TMP("ORLP",$JOB,"LIST","AL",ALINK))
if ALINK=""
QUIT
Begin DoDot:1
+2 IF $LENGTH(ALINK)'<1
IF ($Y+2>IOSL)
DO HEADING
if ORLOUT["^"
QUIT
+3 IF PR=1
WRITE !!," Autolinks: ",ALINK
SET PR=2
+4 IF '$TEST
WRITE !?16,ALINK
End DoDot:1
+5 QUIT
USER ;called by OUTPUT - build list entries (users)
+1 SET USER=""
FOR
SET USER=$ORDER(^TMP("ORLP",$JOB,"LIST","B",USER))
if USER=""
QUIT
Begin DoDot:1
+2 IF $LENGTH(USER)'<1
IF ($Y+2>IOSL)
DO HEADING
if ORLOUT["^"
QUIT
+3 IF PR=1
WRITE !!,"Provider/users: ",USER
SET PR=2
+4 IF '$TEST
WRITE !?16,USER
End DoDot:1
+5 QUIT
PT ;called by OUTPUT - build list entries (patients)
+1 NEW DOTS,SPACE,WRDL
+2 SET $PIECE(DOTS,".",34)=""
SET $PIECE(SPACE," ",28)=""
SET WRDL=""
+3 SET X1=""
FOR
SET X1=$ORDER(^TMP("ORLP",$JOB,"LIST","C",X1))
if X1=""
QUIT
Begin DoDot:1
+4 SET X2=""
FOR
SET X2=$ORDER(^TMP("ORLP",$JOB,"LIST","C",X1,X2))
if X2=""
QUIT
Begin DoDot:2
+5 SET X3=""
FOR
SET X3=$ORDER(^TMP("ORLP",$JOB,"LIST","C",X1,X2,X3))
if X3=""
QUIT
Begin DoDot:3
+6 ; sort="T" Terminal digit sort
+7 IF SORT="T"
SET LINE="("_$EXTRACT(X1,2,5)_") "_$EXTRACT(X2_DOTS,1,33)_" "_$EXTRACT(X3_SPACE,1,27)
DO PT1
QUIT
+8 ; sort="R" Room/Bed sort
+9 IF SORT="R"
Begin DoDot:4
+10 IF PF=1
SET LINE=$EXTRACT(X1_SPACE,1,27)_" "_$EXTRACT(X2_DOTS,1,33)_" ("_X3_")"
QUIT
+11 IF WRDL'=$PIECE(X1,":")
SET LINE=$EXTRACT(X1_SPACE,1,27)_" "_$EXTRACT(X2_DOTS,1,33)_" ("_X3_")"
QUIT
+12 SET LINE=$EXTRACT($EXTRACT(SPACE,1,$LENGTH(WRDL)+1)_$PIECE(X1,":",2)_SPACE,1,27)_" "_$EXTRACT(X2_DOTS,1,33)_" ("_X3_")"
End DoDot:4
DO PT1
QUIT
+13 ; else sort alpha by patient name
+14 SET LINE=$EXTRACT(X1_DOTS,1,33)_"("_X2_") "_X3
DO PT1
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
+16 ;
PT1 IF $LENGTH(X1)'<1
IF ($Y+3>IOSL)
DO HEADING
if ORLOUT["^"
QUIT
+1 IF SORT="R"
SET WRDL=$PIECE(X1,":")
IF PF=1
SET LINE=$EXTRACT(X1_SPACE,1,27)_" "_$EXTRACT(X2_DOTS,1,33)_" ("_X3_")"
+2 IF PF=1
WRITE !!,"Patients: "
SET PF=2
+3 WRITE !?3,LINE
+4 QUIT
TYPESTR ; Assign description strings to ORTTYPE (Team List type) variables.
+1 ; Tag by PKS - 8/99.
+2 ;
+3 IF ORTTYPE="P"
SET ORTTYPE="PERSONAL"
+4 IF ORTTYPE="TA"
SET ORTTYPE="AUTOLINK"
+5 IF ORTTYPE="TM"
SET ORTTYPE="MANUAL"
+6 IF ORTTYPE="MRAL"
SET ORTTYPE="MRAL"
+7 QUIT
