- SCRPO ;BP-CIOFO/KEITH - Report prompting utilities ; 20 Aug 99 7:46 AM
- ;;5.3;Scheduling;**177,297**;AUG 13, 1993
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPO 9006 printed Jan 18, 2025@03:43:47 Page 2
- SCRPO ;BP-CIOFO/KEITH - Report prompting utilities ; 20 Aug 99 7:46 AM
- +1 ;;5.3;Scheduling;**177,297**;AUG 13, 1993
- +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