SCRPO ;BP-CIOFO/KEITH - Report prompting utilities ; 20 Aug 99 7:46 AM
;;5.3;Scheduling;**177,297,1015**;AUG 13, 1993;Build 21
;
DTR(SC,SCDTB,SCDTE) ;Date range prompts
;Input: SC=name of array to return values
; @SC@("DTR","BDT")=begin date (internal^external)
; @SC@("DTR","EDT")=end date (internal^external)
;Input: SCDTB=array to manipulate %DT begin date values (optional)
;Input: SCDTE=array to manipulate %DT end date values (optional)
;Output: '1' for success, '0' otherwise
N %DT M %DT=SCDTB W !
S:'$L($G(%DT)) %DT="AEPX"
I %DT["A" S:'$L($G(%DT("A"))) %DT("A")="Select beginning date: "
D ^%DT I Y<1 Q 0
S @SC@("DTR","BEGIN")=Y X ^DD("DD") S @SC@("DTR","PBDT")=Y
EDT K %DT M %DT=SCDTE W !
S:'$L($G(%DT)) %DT="AEPX"
I %DT["A" S:'$L($G(%DT("A"))) %DT("A")=" Select ending date: "
D ^%DT I Y<1 K SC Q 0
I Y<@SC@("DTR","BEGIN") W !!,$C(7),"End date cannot be before begin date!",! G EDT
S @SC@("DTR","END")=Y X ^DD("DD") S @SC@("DTR","PEDT")=Y
S @SC@("DTR","INCL")=0
D XR(.SC,"DTR","Date Range") Q 1
;
ATYPE(SC) ;Prompt for assignment types
;Input: SC=array to return values (pass by reference)
; @SC@("ATYPE")=assignment types (internal^external)
;Output: '1' for success, '0' otherwise
N DIR,DTOUT,DUOUT
S DIR(0)="S^P:PRIMARY CARE ASSIGNMENTS;N:NON-PRIMARY CARE ASSIGNMENTS;B:BOTH PC AND NON-PC"
S DIR("A")="Specify the type of assignments to include",DIR("B")="BOTH"
W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0
S @SC@("ATYPE")=Y_U_Y(0)
D XR(.SC,"ATYPE","Type of Assignments") Q 1
;
DSUM(SC) ;Prompt for detail or summary
;Input SC=array to return values (pass by reference)
; @SC@("FMT")=format (internal^external)
;Output: '1' for success, '0' otherwise
N DIR,DTOUT,DUOUT
K DIR S DIR(0)="S^D:DETAIL + SUMMARY;S:SUMMARY ONLY"
S DIR("A")="Specify output format",DIR("B")="DETAIL + SUMMARY"
W ! D ^DIR Q:$D(DTOUT)!$D(DUOUT) 0
S @SC@("FMT")=Y_U_Y(0)
D XR(.SC,"FMT","Report Format") Q 1
;
LIST(SC,WHAT,SUBH,LIMIT) ;Get list of entries from a file
;Input: SC=array to return values (pass by reference)
; @SC@(WHAT)="ALL" for all entries, or,
; @SC@(WHAT,ifn)=name of record
; @SC@(WHAT,name,ifn)=""
;Input: WHAT=type of selection
; "DIV" for division
; "TEAM" for TEAM
; "ROLE" for STANDARD POSITION
; "POS" for TEAM POSITION
; "PCP" for PC provider (NEW PERSON)
; "ASPR" for assigned provider (NEW PERSON)
; "APR" for associate provider (NEW PERSON)
; "CLINIC" for enrolled clinic (HOSPITAL LOCATION)
;Input: SUBH='1' to display category subheader (optional)
;Input: LIMIT=maximum selections (optional, default 20)
;Output: '1' for success, '0' otherwise
;
N SCW,SCI,SCOUT,DIC,X,Y,SCA,SCB,SCQUIT,SCS,DTOUT,DUOUT
Q:'$L(WHAT) 0 S:'$G(LIMIT) LIMIT=20 S (SCOUT,SCQUIT)=0
F SCI="DIV","TEAM","ROLE","POS","PCP","ASPR","APR","CLINIC" S SCW(SCI)=""
Q:'$D(SCW(WHAT)) 0
D @WHAT S DIC(0)="AEMQ"
I $G(SUBH) D SUBT^SCRPW50("**** "_SCA_" Selection ****")
S SCB=$J("Select "_SCA_": ",29),DIC("A")=SCB_"ALL// "
I $L($G(SCS)) S DIC("S")=SCS
F SCI=1:1:LIMIT D Q:SCOUT!SCQUIT
.W ! D ^DIC I $D(DTOUT)!$D(DUOUT) S SCQUIT=1 Q
.I SCI=1,X="" W " (ALL)" S @SC@(WHAT)="ALL",SCOUT=1 Q
.I X="" S SCOUT=1 Q
.I Y>0 S @SC@(WHAT,+Y)=$P(Y,U,2),@SC@(WHAT,$P(Y,U,2),+Y)=""
.S DIC("A")=SCB
.Q
D XR(.SC,WHAT,SCA) Q 'SCQUIT
;
DIV S DIC="^DIC(4,",SCA="Institution",SCS="I $D(^SCTM(404.51,""AINST"",+Y))" Q
TEAM S DIC="^SCTM(404.51,",SCA="Team" Q
ROLE S DIC="^SD(403.46,",SCA="Role" Q
POS S DIC="^SCTM(404.57,",SCA="Team Position" Q
PCP S DIC="^VA(200,",SCA="PC Provider" Q
ASPR S DIC="^VA(200,",SCA="Assigned Provider" Q
APR S DIC="^VA(200,",SCA="Associate Provider" Q
CLINIC S DIC="^SC(",SCA="Associated Clinic",DIC("S")="I $P(^(0),U,3)=""C""" Q
;
SORT(SC,SCEL,SCSP) ;Prompt for optional sort elements
;Input: SC=array to return sort order (pass by reference)
;Input: SCX=comma delimited string of element acronyms where
; 'IN' = INSTITUTION
; 'TM' = TEAM
; 'RO' = ROLE
; 'TP' = TEAM POSITION
; 'PR' = PROVIDER
; 'AC' = ASSOCIATED CLINIC
; 'EC' = ENROLLED CLINIC
; 'PT' = PATIENT
; 'PA' = PATIENT
;Input: SCSP=acronym of last sort to add if not selected (optional)
;Output: '0' for abnormal exit, '1' otherwise
; @SC@("SORT",1,elementacronym)=element
; @SC@("SORT",2,elementacronym)=element, etc.
;
N DIR,SCI,SCX,SCY,SCQUIT,SCZ
Q:'$L(SCEL)
S SCQUIT=0
F SCI=1:1:$L(SCEL,",") D
.S SCX=$P(SCEL,",",SCI),SCX=$S(SCX="PA":"PT",SCX="DV":"IN",1:SCX),SCY(SCX)=SCI,SCZ=$P($T(@SCX),";;",2)
.S SCZ(SCX)=$P(SCZ,U,2),SCX=$P(SCZ,U)
.I $L(SCX) S SCX(SCI)=";"_SCX
.Q
Q:'$O(SCX(""))
S SCI=0 D QSORT("Sort output by")
I $L($G(SCSP)),$D(SCY(SCSP)) D
.S SCI=SCI+1,SCZ=$P($T(@SCSP),";;",2),@SC@("SORT",SCI)=$P(SCZ,":")_U_$P(SCZ,":",2)
.Q
D XR(.SC,"SORT","Output will be sorted by") Q 'SCQUIT
;
QSORT(DIRA) ;Prompt for sort
N DTOUT,DUOUT
S DIR("A")=DIRA
S DIR(0)=$$DIR0() Q:DIR(0)=""
D ^DIR I $D(DTOUT)!$D(DUOUT) S SCQUIT=1 Q
Q:X=""
S SCI=SCI+1,@SC@("SORT",SCI)=$S(Y="IN":"DV",Y="PT":"PA",1:Y)_U_Y(0)_U_SCZ(Y)
K SCX(SCY(Y)),SCY(Y) D QSORT("Within "_Y(0)_", sort by")
Q
;
DIR0() ;Return value for DIR(0)
N SCI
S SCX="",SCI=0
F S SCI=$O(SCX(SCI)) Q:'SCI S SCX=SCX_SCX(SCI)
S SCX=$E(SCX,2,999) S:$L(SCX) SCX="SO^"_SCX
Q SCX
;
DV ;;IN:INSTITUTION^SCDIV
IN ;;IN:INSTITUTION^SCDIV
TM ;;TM:TEAM^SCTEAM
RO ;;RO:ROLE^SCROLE
TP ;;TP:TEAM POSITION^SCPOS
PR ;;PR:PROVIDER^SCPROV
EC ;;EC:ENROLLED CLINIC^SCLINIC
AC ;;AC:ASSOCIATED CLINIC^SCLINIC
PA ;;PA:PATIENT^SCPAT
PT ;;PT:PATIENT^SCPAT
;
XR(SC,SUB,VAL) ;Create x-ref for printing parameters
;Input: SC=array to return parameters
;Input: SUB=name of subscript holding parameters being x-ref'd
;Input: VAL=value for item subtitle (optional)
;
S @SC@("XR")=$G(@SC@("XR"))+1,@SC@("XR",@SC@("XR"),SUB)=$G(VAL) Q
;
PPAR(SC,OK,SCT) ;Print report parameters
;Input: SC=array of report parameters
;Input: OK='1' to prompt for parameter ok (optional)
;Input: SCT=report title
;Output: '1' if ok, '0' otherwise
;
N SCL,SCI,SCX,SCOUT,SCLAB,SCF,SCVAL,COL,DTOUT,DUOUT
S COL=$S($E(IOST)="C":12,1:38)
S (SCI,SCOUT)=0,SCLAB="",SCL=1
F S SCI=$O(@SC@("XR",SCI)) Q:'SCI!SCOUT D
.S SCX=$O(@SC@("XR",SCI,"")),SCLAB=@SC@("XR",SCI,SCX)
.I $E(IOST)="C",SCL>18 D WAIT Q:SCOUT S SCL=0
.I $E(IOST)="P",$Y>(IOSL-4) D HDR(.SCT) Q:SCOUT
.S SCL=SCL+1 W ! Q:SCX="SPACE"
.S SCL=SCL+1 W !?(COL),$J(SCLAB,24),": "
.I SCX="DTR" W @SC@("DTR","PBDT")," to ",@SC@("DTR","PEDT") Q
.I $G(@SC@(SCX))="ALL" W "ALL" Q
.I $D(@SC@(SCX))=1 W $P(@SC@(SCX),U,2) Q
.I SCX="SORT" S SCF=0,SCVAL=0 D Q
..F S SCVAL=$O(@SC@(SCX,SCVAL)) Q:'SCVAL!SCOUT D
...I SCF,$E(IOST)="C",SCL>18 D WAIT Q:SCOUT S SCL=0
...I SCF,$E(IOST)="P",$Y>(IOSL-4) D HDR(.SCT) Q:SCOUT
...I SCF W ! S SCL=SCL+1
...W ?(COL+26+$S(SCX="SORT":(SCF*2),1:0)),$P(@SC@(SCX,SCVAL),U,2)
...S SCF=SCF+1
...Q
..Q
.S SCF=0,SCVAL=999999999999
.F S SCVAL=$O(@SC@(SCX,SCVAL)) Q:SCVAL=""!SCOUT D
..I $E(IOST)="C",SCL>18 D WAIT Q:SCOUT S SCL=0
..I $E(IOST)="P",$Y>(IOSL-4) D HDR(.SCT) Q:SCOUT
..I SCF W ! S SCL=SCL+1
..W ?(COL+26+$S(SCX="SORT":(SCF*2),1:0)),SCVAL
..S SCF=SCF+1
..Q
.Q
S SCX=1 I $G(OK) N DIR S DIR(0)="Y",DIR("B")="YES",DIR("A")="OK" D
.W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SCX=0 Q
.S SCX=Y
.Q
Q SCX
;
WAIT N DIR S DIR(0)="E" W ! D ^DIR S SCOUT=Y'=1 W @IOF Q
;
HDR(SCT,SCIOM) ;Print report header
;Input: SCT=array of header lines
;Input: SCIOM=right margin (optional)
;
N SCI
S:'$G(SCIOM) SCIOM=IOM
I $E(IOST)="C",SCFF N DIR S DIR(0)="E" W ! D ^DIR S SCOUT=Y'=1 Q:SCOUT
D STOP Q:SCOUT
I SCFF!($E(IOST)="C") W $$XY^SCRPW50(IOF,1,0)
I $X W $$XY^SCRPW50("",0,0)
W SCLINE
S SCI=0 F S SCI=$O(SCT(SCI)) Q:'SCI D
.W !?(SCIOM-$L(SCT(SCI))\2),SCT(SCI)
.Q
W !,SCLINE,!,"Date printed: ",SCPNOW,?(SCIOM-6-$L(SCPAGE)),"Page: ",SCPAGE
W !,SCLINE S SCFF=1,SCPAGE=SCPAGE+1
Q
;
STOP ;Check for stop task request
S:$D(ZTQUEUED) (SCOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
;
ELIG(DFN) ;Get Primary Eligibility
;Input: DFN=patient ifn
N PRIM,PRIM1
S PRIM=$P($G(^DPT(DFN,.36)),U) Q:PRIM<1 "[unknown]"
S PRIM=$P($G(^DIC(8,PRIM,0)),U,9) Q:PRIM<1 "[unknown]"
;MAS Primary Eligibility Code
S PRIM=$P($G(^DIC(8.1,PRIM,0)),U) Q:PRIM="" "[unknown]"
S PRIM1=PRIM
;
S PRIM=$TR(PRIM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
I PRIM="NON-SERVICE CONNECTED" S PRIM="NSC"
I PRIM["SERVICE CONNECTED" S PRIM=$P(PRIM,"SERVICE CONNECTED")_"SC"_$P(PRIM,"SERVICE CONNECTED",2,999)
I PRIM["LESS THAN" S PRIM=$P(PRIM,"LESS THAN")_"<"_$P(PRIM,"LESS THAN",2,999)
I PRIM[" TO " S PRIM=$P(PRIM," TO ")_"-"_$P(PRIM," TO ",2,999)
I PRIM["%" S PRIM=$TR(PRIM,"%","")
S PRIM=$E(PRIM,1,9)
Q PRIM1_U_PRIM
SCRPO ;BP-CIOFO/KEITH - Report prompting utilities ; 20 Aug 99 7:46 AM
+1 ;;5.3;Scheduling;**177,297,1015**;AUG 13, 1993;Build 21
+2 ;
DTR(SC,SCDTB,SCDTE) ;Date range prompts
+1 ;Input: SC=name of array to return values
+2 ; @SC@("DTR","BDT")=begin date (internal^external)
+3 ; @SC@("DTR","EDT")=end date (internal^external)
+4 ;Input: SCDTB=array to manipulate %DT begin date values (optional)
+5 ;Input: SCDTE=array to manipulate %DT end date values (optional)
+6 ;Output: '1' for success, '0' otherwise
+7 NEW %DT
MERGE %DT=SCDTB
WRITE !
+8 IF '$LENGTH($GET(%DT))
SET %DT="AEPX"
+9 IF %DT["A"
IF '$LENGTH($GET(%DT("A")))
SET %DT("A")="Select beginning date: "
+10 DO ^%DT
IF Y<1
QUIT 0
+11 SET @SC@("DTR","BEGIN")=Y
XECUTE ^DD("DD")
SET @SC@("DTR","PBDT")=Y
EDT KILL %DT
MERGE %DT=SCDTE
WRITE !
+1 IF '$LENGTH($GET(%DT))
SET %DT="AEPX"
+2 IF %DT["A"
IF '$LENGTH($GET(%DT("A")))
SET %DT("A")=" Select ending date: "
+3 DO ^%DT
IF Y<1
KILL SC
QUIT 0
+4 IF Y<@SC@("DTR","BEGIN")
WRITE !!,$CHAR(7),"End date cannot be before begin date!",!
GOTO EDT
+5 SET @SC@("DTR","END")=Y
XECUTE ^DD("DD")
SET @SC@("DTR","PEDT")=Y
+6 SET @SC@("DTR","INCL")=0
+7 DO XR(.SC,"DTR","Date Range")
QUIT 1
+8 ;
ATYPE(SC) ;Prompt for assignment types
+1 ;Input: SC=array to return values (pass by reference)
+2 ; @SC@("ATYPE")=assignment types (internal^external)
+3 ;Output: '1' for success, '0' otherwise
+4 NEW DIR,DTOUT,DUOUT
+5 SET DIR(0)="S^P:PRIMARY CARE ASSIGNMENTS;N:NON-PRIMARY CARE ASSIGNMENTS;B:BOTH PC AND NON-PC"
+6 SET DIR("A")="Specify the type of assignments to include"
SET DIR("B")="BOTH"
+7 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+8 SET @SC@("ATYPE")=Y_U_Y(0)
+9 DO XR(.SC,"ATYPE","Type of Assignments")
QUIT 1
+10 ;
DSUM(SC) ;Prompt for detail or summary
+1 ;Input SC=array to return values (pass by reference)
+2 ; @SC@("FMT")=format (internal^external)
+3 ;Output: '1' for success, '0' otherwise
+4 NEW DIR,DTOUT,DUOUT
+5 KILL DIR
SET DIR(0)="S^D:DETAIL + SUMMARY;S:SUMMARY ONLY"
+6 SET DIR("A")="Specify output format"
SET DIR("B")="DETAIL + SUMMARY"
+7 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+8 SET @SC@("FMT")=Y_U_Y(0)
+9 DO XR(.SC,"FMT","Report Format")
QUIT 1
+10 ;
LIST(SC,WHAT,SUBH,LIMIT) ;Get list of entries from a file
+1 ;Input: SC=array to return values (pass by reference)
+2 ; @SC@(WHAT)="ALL" for all entries, or,
+3 ; @SC@(WHAT,ifn)=name of record
+4 ; @SC@(WHAT,name,ifn)=""
+5 ;Input: WHAT=type of selection
+6 ; "DIV" for division
+7 ; "TEAM" for TEAM
+8 ; "ROLE" for STANDARD POSITION
+9 ; "POS" for TEAM POSITION
+10 ; "PCP" for PC provider (NEW PERSON)
+11 ; "ASPR" for assigned provider (NEW PERSON)
+12 ; "APR" for associate provider (NEW PERSON)
+13 ; "CLINIC" for enrolled clinic (HOSPITAL LOCATION)
+14 ;Input: SUBH='1' to display category subheader (optional)
+15 ;Input: LIMIT=maximum selections (optional, default 20)
+16 ;Output: '1' for success, '0' otherwise
+17 ;
+18 NEW SCW,SCI,SCOUT,DIC,X,Y,SCA,SCB,SCQUIT,SCS,DTOUT,DUOUT
+19 IF '$LENGTH(WHAT)
QUIT 0
IF '$GET(LIMIT)
SET LIMIT=20
SET (SCOUT,SCQUIT)=0
+20 FOR SCI="DIV","TEAM","ROLE","POS","PCP","ASPR","APR","CLINIC"
SET SCW(SCI)=""
+21 IF '$DATA(SCW(WHAT))
QUIT 0
+22 DO @WHAT
SET DIC(0)="AEMQ"
+23 IF $GET(SUBH)
DO SUBT^SCRPW50("**** "_SCA_" Selection ****")
+24 SET SCB=$JUSTIFY("Select "_SCA_": ",29)
SET DIC("A")=SCB_"ALL// "
+25 IF $LENGTH($GET(SCS))
SET DIC("S")=SCS
+26 FOR SCI=1:1:LIMIT
Begin DoDot:1
+27 WRITE !
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SCQUIT=1
QUIT
+28 IF SCI=1
IF X=""
WRITE " (ALL)"
SET @SC@(WHAT)="ALL"
SET SCOUT=1
QUIT
+29 IF X=""
SET SCOUT=1
QUIT
+30 IF Y>0
SET @SC@(WHAT,+Y)=$PIECE(Y,U,2)
SET @SC@(WHAT,$PIECE(Y,U,2),+Y)=""
+31 SET DIC("A")=SCB
+32 QUIT
End DoDot:1
IF SCOUT!SCQUIT
QUIT
+33 DO XR(.SC,WHAT,SCA)
QUIT 'SCQUIT
+34 ;
DIV SET DIC="^DIC(4,"
SET SCA="Institution"
SET SCS="I $D(^SCTM(404.51,""AINST"",+Y))"
QUIT
TEAM SET DIC="^SCTM(404.51,"
SET SCA="Team"
QUIT
ROLE SET DIC="^SD(403.46,"
SET SCA="Role"
QUIT
POS SET DIC="^SCTM(404.57,"
SET SCA="Team Position"
QUIT
PCP SET DIC="^VA(200,"
SET SCA="PC Provider"
QUIT
ASPR SET DIC="^VA(200,"
SET SCA="Assigned Provider"
QUIT
APR SET DIC="^VA(200,"
SET SCA="Associate Provider"
QUIT
CLINIC SET DIC="^SC("
SET SCA="Associated Clinic"
SET DIC("S")="I $P(^(0),U,3)=""C"""
QUIT
+1 ;
SORT(SC,SCEL,SCSP) ;Prompt for optional sort elements
+1 ;Input: SC=array to return sort order (pass by reference)
+2 ;Input: SCX=comma delimited string of element acronyms where
+3 ; 'IN' = INSTITUTION
+4 ; 'TM' = TEAM
+5 ; 'RO' = ROLE
+6 ; 'TP' = TEAM POSITION
+7 ; 'PR' = PROVIDER
+8 ; 'AC' = ASSOCIATED CLINIC
+9 ; 'EC' = ENROLLED CLINIC
+10 ; 'PT' = PATIENT
+11 ; 'PA' = PATIENT
+12 ;Input: SCSP=acronym of last sort to add if not selected (optional)
+13 ;Output: '0' for abnormal exit, '1' otherwise
+14 ; @SC@("SORT",1,elementacronym)=element
+15 ; @SC@("SORT",2,elementacronym)=element, etc.
+16 ;
+17 NEW DIR,SCI,SCX,SCY,SCQUIT,SCZ
+18 IF '$LENGTH(SCEL)
QUIT
+19 SET SCQUIT=0
+20 FOR SCI=1:1:$LENGTH(SCEL,",")
Begin DoDot:1
+21 SET SCX=$PIECE(SCEL,",",SCI)
SET SCX=$SELECT(SCX="PA":"PT",SCX="DV":"IN",1:SCX)
SET SCY(SCX)=SCI
SET SCZ=$PIECE($TEXT(@SCX),";;",2)
+22 SET SCZ(SCX)=$PIECE(SCZ,U,2)
SET SCX=$PIECE(SCZ,U)
+23 IF $LENGTH(SCX)
SET SCX(SCI)=";"_SCX
+24 QUIT
End DoDot:1
+25 IF '$ORDER(SCX(""))
QUIT
+26 SET SCI=0
DO QSORT("Sort output by")
+27 IF $LENGTH($GET(SCSP))
IF $DATA(SCY(SCSP))
Begin DoDot:1
+28 SET SCI=SCI+1
SET SCZ=$PIECE($TEXT(@SCSP),";;",2)
SET @SC@("SORT",SCI)=$PIECE(SCZ,":")_U_$PIECE(SCZ,":",2)
+29 QUIT
End DoDot:1
+30 DO XR(.SC,"SORT","Output will be sorted by")
QUIT 'SCQUIT
+31 ;
QSORT(DIRA) ;Prompt for sort
+1 NEW DTOUT,DUOUT
+2 SET DIR("A")=DIRA
+3 SET DIR(0)=$$DIR0()
IF DIR(0)=""
QUIT
+4 DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SCQUIT=1
QUIT
+5 IF X=""
QUIT
+6 SET SCI=SCI+1
SET @SC@("SORT",SCI)=$SELECT(Y="IN":"DV",Y="PT":"PA",1:Y)_U_Y(0)_U_SCZ(Y)
+7 KILL SCX(SCY(Y)),SCY(Y)
DO QSORT("Within "_Y(0)_", sort by")
+8 QUIT
+9 ;
DIR0() ;Return value for DIR(0)
+1 NEW SCI
+2 SET SCX=""
SET SCI=0
+3 FOR
SET SCI=$ORDER(SCX(SCI))
IF 'SCI
QUIT
SET SCX=SCX_SCX(SCI)
+4 SET SCX=$EXTRACT(SCX,2,999)
IF $LENGTH(SCX)
SET SCX="SO^"_SCX
+5 QUIT SCX
+6 ;
DV ;;IN:INSTITUTION^SCDIV
IN ;;IN:INSTITUTION^SCDIV
TM ;;TM:TEAM^SCTEAM
RO ;;RO:ROLE^SCROLE
TP ;;TP:TEAM POSITION^SCPOS
PR ;;PR:PROVIDER^SCPROV
EC ;;EC:ENROLLED CLINIC^SCLINIC
AC ;;AC:ASSOCIATED CLINIC^SCLINIC
PA ;;PA:PATIENT^SCPAT
PT ;;PT:PATIENT^SCPAT
+1 ;
XR(SC,SUB,VAL) ;Create x-ref for printing parameters
+1 ;Input: SC=array to return parameters
+2 ;Input: SUB=name of subscript holding parameters being x-ref'd
+3 ;Input: VAL=value for item subtitle (optional)
+4 ;
+5 SET @SC@("XR")=$GET(@SC@("XR"))+1
SET @SC@("XR",@SC@("XR"),SUB)=$GET(VAL)
QUIT
+6 ;
PPAR(SC,OK,SCT) ;Print report parameters
+1 ;Input: SC=array of report parameters
+2 ;Input: OK='1' to prompt for parameter ok (optional)
+3 ;Input: SCT=report title
+4 ;Output: '1' if ok, '0' otherwise
+5 ;
+6 NEW SCL,SCI,SCX,SCOUT,SCLAB,SCF,SCVAL,COL,DTOUT,DUOUT
+7 SET COL=$SELECT($EXTRACT(IOST)="C":12,1:38)
+8 SET (SCI,SCOUT)=0
SET SCLAB=""
SET SCL=1
+9 FOR
SET SCI=$ORDER(@SC@("XR",SCI))
IF 'SCI!SCOUT
QUIT
Begin DoDot:1
+10 SET SCX=$ORDER(@SC@("XR",SCI,""))
SET SCLAB=@SC@("XR",SCI,SCX)
+11 IF $EXTRACT(IOST)="C"
IF SCL>18
DO WAIT
IF SCOUT
QUIT
SET SCL=0
+12 IF $EXTRACT(IOST)="P"
IF $Y>(IOSL-4)
DO HDR(.SCT)
IF SCOUT
QUIT
+13 SET SCL=SCL+1
WRITE !
IF SCX="SPACE"
QUIT
+14 SET SCL=SCL+1
WRITE !?(COL),$JUSTIFY(SCLAB,24),": "
+15 IF SCX="DTR"
WRITE @SC@("DTR","PBDT")," to ",@SC@("DTR","PEDT")
QUIT
+16 IF $GET(@SC@(SCX))="ALL"
WRITE "ALL"
QUIT
+17 IF $DATA(@SC@(SCX))=1
WRITE $PIECE(@SC@(SCX),U,2)
QUIT
+18 IF SCX="SORT"
SET SCF=0
SET SCVAL=0
Begin DoDot:2
+19 FOR
SET SCVAL=$ORDER(@SC@(SCX,SCVAL))
IF 'SCVAL!SCOUT
QUIT
Begin DoDot:3
+20 IF SCF
IF $EXTRACT(IOST)="C"
IF SCL>18
DO WAIT
IF SCOUT
QUIT
SET SCL=0
+21 IF SCF
IF $EXTRACT(IOST)="P"
IF $Y>(IOSL-4)
DO HDR(.SCT)
IF SCOUT
QUIT
+22 IF SCF
WRITE !
SET SCL=SCL+1
+23 WRITE ?(COL+26+$SELECT(SCX="SORT":(SCF*2),1:0)),$PIECE(@SC@(SCX,SCVAL),U,2)
+24 SET SCF=SCF+1
+25 QUIT
End DoDot:3
+26 QUIT
End DoDot:2
QUIT
+27 SET SCF=0
SET SCVAL=999999999999
+28 FOR
SET SCVAL=$ORDER(@SC@(SCX,SCVAL))
IF SCVAL=""!SCOUT
QUIT
Begin DoDot:2
+29 IF $EXTRACT(IOST)="C"
IF SCL>18
DO WAIT
IF SCOUT
QUIT
SET SCL=0
+30 IF $EXTRACT(IOST)="P"
IF $Y>(IOSL-4)
DO HDR(.SCT)
IF SCOUT
QUIT
+31 IF SCF
WRITE !
SET SCL=SCL+1
+32 WRITE ?(COL+26+$SELECT(SCX="SORT":(SCF*2),1:0)),SCVAL
+33 SET SCF=SCF+1
+34 QUIT
End DoDot:2
+35 QUIT
End DoDot:1
+36 SET SCX=1
IF $GET(OK)
NEW DIR
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="OK"
Begin DoDot:1
+37 WRITE !
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET SCX=0
QUIT
+38 SET SCX=Y
+39 QUIT
End DoDot:1
+40 QUIT SCX
+41 ;
WAIT NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET SCOUT=Y'=1
WRITE @IOF
QUIT
+1 ;
HDR(SCT,SCIOM) ;Print report header
+1 ;Input: SCT=array of header lines
+2 ;Input: SCIOM=right margin (optional)
+3 ;
+4 NEW SCI
+5 IF '$GET(SCIOM)
SET SCIOM=IOM
+6 IF $EXTRACT(IOST)="C"
IF SCFF
NEW DIR
SET DIR(0)="E"
WRITE !
DO ^DIR
SET SCOUT=Y'=1
IF SCOUT
QUIT
+7 DO STOP
IF SCOUT
QUIT
+8 IF SCFF!($EXTRACT(IOST)="C")
WRITE $$XY^SCRPW50(IOF,1,0)
+9 IF $X
WRITE $$XY^SCRPW50("",0,0)
+10 WRITE SCLINE
+11 SET SCI=0
FOR
SET SCI=$ORDER(SCT(SCI))
IF 'SCI
QUIT
Begin DoDot:1
+12 WRITE !?(SCIOM-$LENGTH(SCT(SCI))\2),SCT(SCI)
+13 QUIT
End DoDot:1
+14 WRITE !,SCLINE,!,"Date printed: ",SCPNOW,?(SCIOM-6-$LENGTH(SCPAGE)),"Page: ",SCPAGE
+15 WRITE !,SCLINE
SET SCFF=1
SET SCPAGE=SCPAGE+1
+16 QUIT
+17 ;
STOP ;Check for stop task request
+1 IF $DATA(ZTQUEUED)
SET (SCOUT,ZTSTOP)=$SELECT($$S^%ZTLOAD:1,1:0)
QUIT
+2 ;
ELIG(DFN) ;Get Primary Eligibility
+1 ;Input: DFN=patient ifn
+2 NEW PRIM,PRIM1
+3 SET PRIM=$PIECE($GET(^DPT(DFN,.36)),U)
IF PRIM<1
QUIT "[unknown]"
+4 SET PRIM=$PIECE($GET(^DIC(8,PRIM,0)),U,9)
IF PRIM<1
QUIT "[unknown]"
+5 ;MAS Primary Eligibility Code
+6 SET PRIM=$PIECE($GET(^DIC(8.1,PRIM,0)),U)
IF PRIM=""
QUIT "[unknown]"
+7 SET PRIM1=PRIM
+8 ;
+9 SET PRIM=$TRANSLATE(PRIM,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+10 IF PRIM="NON-SERVICE CONNECTED"
SET PRIM="NSC"
+11 IF PRIM["SERVICE CONNECTED"
SET PRIM=$PIECE(PRIM,"SERVICE CONNECTED")_"SC"_$PIECE(PRIM,"SERVICE CONNECTED",2,999)
+12 IF PRIM["LESS THAN"
SET PRIM=$PIECE(PRIM,"LESS THAN")_"<"_$PIECE(PRIM,"LESS THAN",2,999)
+13 IF PRIM[" TO "
SET PRIM=$PIECE(PRIM," TO ")_"-"_$PIECE(PRIM," TO ",2,999)
+14 IF PRIM["%"
SET PRIM=$TRANSLATE(PRIM,"%","")
+15 SET PRIM=$EXTRACT(PRIM,1,9)
+16 QUIT PRIM1_U_PRIM
