- 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
- 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
