IBENDS1 ;DAL/JCH - NDS PAYERS MTOP UTILITIES ;15-JUN-2017
;;2.0;INTEGRATED BILLING;**585**;21-MAR-94;Build 68
;
; Type of Plan (#355.1) to Master Type of Plan (#355.99) associations
; Available at Master Type of Plan Report [IBMTOP RPT] option, at the following menu path:
; Billing Supervisor Menu [IB BILLING SUPERVISOR MENU]
; MCCR System Definition Menu [MCCR SYSTEM DEFINITION MENU]
; Master Type of Plan Menu [IBMTOP MNU]
; Master Type of Plan Report [IBMTOP RPT]
Q
;
EN ; MTOP Report Entry point
N IBEOUT,IBEION
S IBEOUT=0
F Q:$G(IBEOUT) D
.D MAIN Q:IBEOUT
.N DIR W !!
.S DIR(0)="Y",DIR("B")="Y",DIR("A")="Run report again" D ^DIR
.S:X'="Y" IBEOUT=1
Q
;
MAIN ; Driver loop
N IBESUM,IBEMUA,IBESTOP,IBEOUTP
S IBESTOP=0
;
D CLEAR^VALM1
;
W !!?2,"This report will print Plan Types from the TYPE OF PLAN"
W !?2,"(#355.1) file and each Plan Type's mapping relationship"
W !?2,"to the Public Health Data Standards Consortium (PHDSC)"
w !?2,"Source of Payment in the MASTER TYPE OF PLAN (#355.99) file."
;
; Select (M)apped, (U)nmapped, or (A)ll entries from TYPE OF PLAN (#355.1) file.
W ! D MUA(.IBEMUA) I '$D(IBEMUA)!$G(IBEOUT) S IBEOUT=1 Q
;
; Select summary report or detailed
S IBESUM=$$SUMMARY I 'IBESUM Q
;
; Select output format
S IBEOUTP=$$OUT I IBESTOP Q
;
; Select device
I $$SELDEV()!IBESTOP Q
;
I IBEOUTP="R" W !!,"<*> please wait <*>"
U IO D DQ
;
Q
;
DQ ; report (queue) starts here
N IBETOPI,IBEMTOPI,IBETOP0,IBEMTOP0,IBENAME
;
K ^TMP($J,"IBENDS1")
; build list of plan types
S IBETOPI=0 F S IBETOPI=$O(^IBE(355.1,IBETOPI)) Q:'IBETOPI D
.S IBETOP0=$G(^IBE(355.1,IBETOPI,0)),IBEMTOPI=$P(IBETOP0,"^",5)
.I $G(IBEMUA)="U",$G(IBEMTOPI) Q
.I $G(IBEMUA)="M",'$G(IBEMTOPI) Q
.S IBEMTOP0=$S($G(IBEMTOPI):$G(^IBEMTOP(355.99,+IBEMTOPI,0)),1:"Not Mapped")
.I IBEMTOPI S $P(IBEMTOP0,"^",4)=IBEMTOPI
.S IBENAME=$P(IBETOP0,"^")
.S ^TMP($J,"IBENDS1",IBENAME,IBETOPI,"TOP")=$G(IBETOP0)
.S ^TMP($J,"IBENDS1",IBENAME,IBETOPI,"MTOP")=$G(IBEMTOP0)
;
D PRINT
;
D ^%ZISC
K ^TMP($J,"IBENDS1")
Q
;
PRINT ; Print output
N MAXCNT,IBESTOP,IBEPGCNT,IBEHDR,CRT,IBCNT
I IOST["C-" S MAXCNT=IOSL-10,CRT=1
E S MAXCNT=IOSL-6,CRT=0
I IBESUM=1 S MAXCNT=MAXCNT+5
S IBEPGCNT=0,IBESTOP=0
;
I '$D(^TMP($J,"IBENDS1")) D HEADER W !!!?5,"No Data Found" Q
;
N IBETOPI,IBENAME
S IBENAME="" F IBCNT=1:1 S IBENAME=$O(^TMP($J,"IBENDS1",IBENAME)) Q:IBENAME=""!IBESTOP D
.S IBETOPI=0 F S IBETOPI=$O(^TMP($J,"IBENDS1",IBENAME,IBETOPI)) Q:'IBETOPI!IBESTOP D
..D PRINT2(IBENAME,IBETOPI)
Q
;
PRINT2(IBENAME,IBETOPI) ; Continue printing output
N IBETOP0,IBEMTOP0,IBECT,IBECTS,IBECTX,IBTOPST
N IBEMTST,IBEMTED,IBEMTOPI,IBEMTEDI,IBEMPAR,IBEMPARX
N IBEMREPL,IBEMREPX,IBEMV0
;
I $G(IBEOUTP)="E" D DELIM(IBENAME,IBETOPI) Q
;
I ($Y+1>MAXCNT)!'IBEPGCNT D HEADER Q:IBESTOP
S IBETOP0=$G(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"TOP"))
S IBTOPST=$P(IBETOP0,"^",4),IBTOPST=$S(IBTOPST:"INACTIVE",1:"ACTIVE")
D PRINTOP(IBENAME,IBETOPI)
;
Q:'IBEMTOPI
I $G(IBESUM)=2 D
.S IBEMTED=$$NOW^XLFDT,IBEMTED=$O(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED),-1)
.I IBEMTED D ; This should always be true, if data came from STS MFS process
..S IBEMTEDI="",IBEMTEDI=$O(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED,IBEMTEDI))
..S IBEMTST=$P(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS",IBEMTEDI,0),"^",2)
..W ?22," PHDSC Status: ",$S(IBEMTST:"ACTIVE",1:"INACTIVE")
.S IBEMPAR=$P(IBEMTOP0,"^",3) I IBEMPAR S IBEMPARX=$P($G(^IBEMTOP(355.99,IBEMPAR,0)),"^")
.I $L($G(IBEMPARX)) W !,"PHDSC Parent: ",IBEMPARX
.S IBEMV0=$G(^IBEMTOP(355.99,IBEMTOPI,"VUID"))
.S IBEMREPL=$P(IBEMV0,"^",3) I IBEMREPL S IBEMREPX=$P($G(^IBEMTOP(355.99,IBEMREPL,0)),"^")
.I $L($G(IBEMREPX)) W !,"MTOP PHDSC Replaced By: ",IBEMREPX
Q
;
MUA(IBEMUA) ; Select (M)apped, (U)nmapped, or(A)ll - entries from 355.1 mapped to 355.99
N DIR,DIRUT,Y
W ! S DIR(0)="SAO^M:(M)apped;U:(U)nmapped;A:(A)ll"
S DIR("?")="Enter ^ to exit"
S DIR("A",1)="Run the report for"
S DIR("A")="(M)apped, (U)nmapped, or (A)ll Type of Plan entries: ",DIR("B")="A" D ^DIR
I $D(DIRUT) S IBEOUT=1 Q
S IBEMUA=Y
Q
;
SUMMARY() ; ask to print detailed or summary report
N DIR,DIRUT,X,Y
S DIR(0)="SOA^D:Detailed;S:Summary;",DIR("B")="Summary"
S DIR("A")="Type of report to print: "
W ! D ^DIR
I $D(DIRUT) S IBESTOP=1 Q 0
Q $S(Y="S":1,Y="D":2,1:0)
;
OUT() ; select Excel or Report format
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="SA^E:Excel;R:Report"
S DIR("A")="(E)xcel Format or (R)eport Format: "
S DIR("B")="Report"
D ^DIR I $D(DIRUT) S IBESTOP=1 Q ""
Q Y
;
DELIM(IBENAME,IBETOPI) ; Print output in "^" delimited format
; Print data in (E)xcel format, e.g., "data^data^data"
N IBSTRING,IBABB,IBCATX,IBTOPST
N IBMCOD,IBMNAM,IBMSTAT,IBMAP
I IBCNT=1 D
.I IBESUM=2 W !,"TYPE OF PLAN NAME^PLAN ABBREVIATION^PLAN STATUS^MAJOR CATEGORY^MAPPED/NOT MAPPED^MTOP PHDSC NAME^MTOP PHDSC CODE^MTOP PHDSC STATUS^PARENT^REPLACED BY"
.I IBESUM=1 W !,"TYPE OF PLAN NAME^MAPPED/NOT MAPPED^MTOP PHDSC NAME"
S IBETOP0=$G(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"TOP"))
S IBTOPST=$P(IBETOP0,"^",4),IBTOPST=$S(IBTOPST:"INACTIVE",1:"ACTIVE")
S IBABB=$P(IBETOP0,"^",2)
S IBECT=$P(IBETOP0,"^",3) D
.N IBECTS,IBERR
.S IBCATX=""
.D FIND^DIC(355.1,,".01;.03","A","`"_+$G(IBETOPI),,,,,"IBECTS","IBERR")
.I $G(IBENAME)=$G(IBECTS("DILIST","ID",1,.01)) S IBCATX=$G(IBECTS("DILIST","ID",1,.03))
S IBEMTOP0=$G(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"MTOP"))
S IBEMTOPI=+$P(IBEMTOP0,"^",4)
S IBMNAM=$P(IBEMTOP0,"^"),IBMCOD=$P(IBEMTOP0,"^",2)
S IBMAP=$S(IBEMTOPI:"MAPPED",1:"NOT MAPPED")
I 'IBEMTOPI D Q
.I IBESUM=2 S IBSTRING=IBENAME_"^"_IBABB_"^"_IBTOPST_"^"_IBCATX_"^"_IBMAP
.I IBESUM'=2 S IBSTRING=IBENAME_"^"_IBMAP
.W !,IBSTRING
S IBEMTED=$$NOW^XLFDT,IBEMTED=$O(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED),-1)
S IBEMTEDI="",IBEMTEDI=$O(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED,IBEMTEDI))
S IBEMTST=$P(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS",IBEMTEDI,0),"^",2)
S IBMSTAT=$S(IBEMTST:"ACTIVE",1:"INACTIVE")
S IBEMPAR=+$P(IBEMTOP0,"^",3)
S IBEMPARX=$P($G(^IBEMTOP(355.99,IBEMPAR,0)),"^")
S IBEMV0=$G(^IBEMTOP(355.99,IBEMTOPI,"VUID"))
S IBEMREPL=+$P(IBEMV0,"^",3)
S IBEMREPX=$P($G(^IBEMTOP(355.99,IBEMREPL,0)),"^")
I IBESUM=2 S IBSTRING=IBENAME_"^"_IBABB_"^"_IBTOPST_"^"_IBCATX_"^"_IBMAP_"^"_IBMNAM_"^"_IBMCOD_"^"_IBMSTAT_"^"_IBEMPARX_"^"_IBEMREPX
I IBESUM'=2 S IBSTRING=IBENAME_"^"_IBMAP_"^"_IBMNAM
W !,IBSTRING
Q
;
SELDEV() ; Prompt for output device, return 1 if queued
I IBEOUTP="E" D
.N DIR,X,Y
.S DIR("A",1)=""
.S DIR("A",2)=" ************************************************************"
.S DIR("A",3)=" ** You selected a Delimited report. Please verify you **"
.S DIR("A",4)=" ** you have turned logging on to capture the output. **"
.S DIR("A",5)=" ** **"
.S DIR("A",6)=" ** To avoid undesired wrapping, enter '0;199;999' at **"
.S DIR("A",7)=" ** the 'DEVICE:' prompt. The Terminal Session display **"
.S DIR("A",8)=" ** may need to be set to 199 columns. **"
.S DIR("A",9)=" ************************************************************"
.S DIR("A",10)=""
.S DIR("A",11)="",DIR("A",12)=""
.S DIR("A")=" Press return to continue"
.S DIR(0)="EA" D ^DIR W !
;
N IBEDONE
W !,"You may queue this report to print at a later time.",!
F Q:$G(IBESTOP)!$G(IBEDONE) D
.K %ZIS,IOP,POP,ZTSK N I S IBEION=$I,%ZIS="QM"
.D ^%ZIS K %ZIS
.I POP S IOP=IBEION D ^%ZIS K IOP,IBEION D Q
..N DIR,X,Y
..S DIR(0)="YA",DIR("A",1)=" ** No Device Selected **",DIR("A")="Select a different device? (Y/N) " D ^DIR
..S:'Y IBESTOP=1
.S IBEDONE=1
I $D(IO("Q")) D Q 1
.N ZTDESC,ZTSAVE,ZTRTN
.S ZTDESC="Type of Plan to MTOP Mapping Report",ZTRTN="DQ^IBENDS1"
.S ZTSAVE("DATE*")="",ZTSAVE("IBE*")="",ZTSAVE("ZTREQ")="@"
.K IO("Q") D ^%ZTLOAD W:$D(ZTSK) !,"Report is Queued to print!" K ZTSK
Q:$G(IBESTOP) -1
Q 0
;
N IBEHDR,IBETAB,IBESPACE
S IBESTOP=0
I CRT,IBEPGCNT>0,'$D(ZTQUEUED) D Q:IBESTOP
.N DIR,LIN
.I MAXCNT<51 F LIN=1:1:(MAXCNT-$Y) W !
.W !
.S DIR(0)="E" D ^DIR K DIR
.I 'Y S IBESTOP=1 Q
S IBEPGCNT=IBEPGCNT+1
W @IOF,!
S $P(IBESPACE," ",132)=""
S IBEHDR=" Type Of Plan Map to Master Type of Plan (MTOP) "
S IBEHDR(1)=" PHDSC Source of Payment Typology Report"
S IBEHDR=IBEHDR_"Page: "_IBEPGCNT,IBETAB=132-$L(IBEHDR)-1
W IBEHDR
W !,IBEHDR(1)
Q
;
PRINTOP(IBENAME,IBETOPI) ; Print Type of Plan file (#355.1) entry
W !!,"Type of Plan: ",$P(IBETOP0,"^")
I $G(IBESUM)=2 D
.W !,"Abbreviation: ",$P(IBETOP0,"^",2)
.W ?30,"Status: ",IBTOPST
.S IBECT=$P(IBETOP0,"^",3) I $L(IBECT) D
..D FIELD^DID(355.1,.03,"","POINTER","IBECTS")
..S IBECTX=$P(IBECTS("POINTER"),+IBECT_":",2),IBECTX=$P(IBECTX,";")
..I $L(IBECTX) W !?4,"Category: ",IBECTX
S IBEMTOP0=$G(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"MTOP"))
S IBEMTOPI=+$P(IBEMTOP0,"^",4)
W !?2,"Mapped to PHDSC Source of Payment?: ",$S(IBEMTOPI:"YES",1:"NO")
Q:'IBEMTOPI
W !?2,"PHDSC Name: ",$P(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"MTOP"),"^")
W !?2,"PHDSC Code: ",$P(^TMP($J,"IBENDS1",IBENAME,IBETOPI,"MTOP"),"^",2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBENDS1 9472 printed Apr 09, 2024@21:11:55 Page 2
IBENDS1 ;DAL/JCH - NDS PAYERS MTOP UTILITIES ;15-JUN-2017
+1 ;;2.0;INTEGRATED BILLING;**585**;21-MAR-94;Build 68
+2 ;
+3 ; Type of Plan (#355.1) to Master Type of Plan (#355.99) associations
+4 ; Available at Master Type of Plan Report [IBMTOP RPT] option, at the following menu path:
+5 ; Billing Supervisor Menu [IB BILLING SUPERVISOR MENU]
+6 ; MCCR System Definition Menu [MCCR SYSTEM DEFINITION MENU]
+7 ; Master Type of Plan Menu [IBMTOP MNU]
+8 ; Master Type of Plan Report [IBMTOP RPT]
+9 QUIT
+10 ;
EN ; MTOP Report Entry point
+1 NEW IBEOUT,IBEION
+2 SET IBEOUT=0
+3 FOR
if $GET(IBEOUT)
QUIT
Begin DoDot:1
+4 DO MAIN
if IBEOUT
QUIT
+5 NEW DIR
WRITE !!
+6 SET DIR(0)="Y"
SET DIR("B")="Y"
SET DIR("A")="Run report again"
DO ^DIR
+7 if X'="Y"
SET IBEOUT=1
End DoDot:1
+8 QUIT
+9 ;
MAIN ; Driver loop
+1 NEW IBESUM,IBEMUA,IBESTOP,IBEOUTP
+2 SET IBESTOP=0
+3 ;
+4 DO CLEAR^VALM1
+5 ;
+6 WRITE !!?2,"This report will print Plan Types from the TYPE OF PLAN"
+7 WRITE !?2,"(#355.1) file and each Plan Type's mapping relationship"
+8 WRITE !?2,"to the Public Health Data Standards Consortium (PHDSC)"
+9 WRITE !?2,"Source of Payment in the MASTER TYPE OF PLAN (#355.99) file."
+10 ;
+11 ; Select (M)apped, (U)nmapped, or (A)ll entries from TYPE OF PLAN (#355.1) file.
+12 WRITE !
DO MUA(.IBEMUA)
IF '$DATA(IBEMUA)!$GET(IBEOUT)
SET IBEOUT=1
QUIT
+13 ;
+14 ; Select summary report or detailed
+15 SET IBESUM=$$SUMMARY
IF 'IBESUM
QUIT
+16 ;
+17 ; Select output format
+18 SET IBEOUTP=$$OUT
IF IBESTOP
QUIT
+19 ;
+20 ; Select device
+21 IF $$SELDEV()!IBESTOP
QUIT
+22 ;
+23 IF IBEOUTP="R"
WRITE !!,"<*> please wait <*>"
+24 USE IO
DO DQ
+25 ;
+26 QUIT
+27 ;
DQ ; report (queue) starts here
+1 NEW IBETOPI,IBEMTOPI,IBETOP0,IBEMTOP0,IBENAME
+2 ;
+3 KILL ^TMP($JOB,"IBENDS1")
+4 ; build list of plan types
+5 SET IBETOPI=0
FOR
SET IBETOPI=$ORDER(^IBE(355.1,IBETOPI))
if 'IBETOPI
QUIT
Begin DoDot:1
+6 SET IBETOP0=$GET(^IBE(355.1,IBETOPI,0))
SET IBEMTOPI=$PIECE(IBETOP0,"^",5)
+7 IF $GET(IBEMUA)="U"
IF $GET(IBEMTOPI)
QUIT
+8 IF $GET(IBEMUA)="M"
IF '$GET(IBEMTOPI)
QUIT
+9 SET IBEMTOP0=$SELECT($GET(IBEMTOPI):$GET(^IBEMTOP(355.99,+IBEMTOPI,0)),1:"Not Mapped")
+10 IF IBEMTOPI
SET $PIECE(IBEMTOP0,"^",4)=IBEMTOPI
+11 SET IBENAME=$PIECE(IBETOP0,"^")
+12 SET ^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"TOP")=$GET(IBETOP0)
+13 SET ^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"MTOP")=$GET(IBEMTOP0)
End DoDot:1
+14 ;
+15 DO PRINT
+16 ;
+17 DO ^%ZISC
+18 KILL ^TMP($JOB,"IBENDS1")
+19 QUIT
+20 ;
PRINT ; Print output
+1 NEW MAXCNT,IBESTOP,IBEPGCNT,IBEHDR,CRT,IBCNT
+2 IF IOST["C-"
SET MAXCNT=IOSL-10
SET CRT=1
+3 IF '$TEST
SET MAXCNT=IOSL-6
SET CRT=0
+4 IF IBESUM=1
SET MAXCNT=MAXCNT+5
+5 SET IBEPGCNT=0
SET IBESTOP=0
+6 ;
+7 IF '$DATA(^TMP($JOB,"IBENDS1"))
DO HEADER
WRITE !!!?5,"No Data Found"
QUIT
+8 ;
+9 NEW IBETOPI,IBENAME
+10 SET IBENAME=""
FOR IBCNT=1:1
SET IBENAME=$ORDER(^TMP($JOB,"IBENDS1",IBENAME))
if IBENAME=""!IBESTOP
QUIT
Begin DoDot:1
+11 SET IBETOPI=0
FOR
SET IBETOPI=$ORDER(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI))
if 'IBETOPI!IBESTOP
QUIT
Begin DoDot:2
+12 DO PRINT2(IBENAME,IBETOPI)
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
PRINT2(IBENAME,IBETOPI) ; Continue printing output
+1 NEW IBETOP0,IBEMTOP0,IBECT,IBECTS,IBECTX,IBTOPST
+2 NEW IBEMTST,IBEMTED,IBEMTOPI,IBEMTEDI,IBEMPAR,IBEMPARX
+3 NEW IBEMREPL,IBEMREPX,IBEMV0
+4 ;
+5 IF $GET(IBEOUTP)="E"
DO DELIM(IBENAME,IBETOPI)
QUIT
+6 ;
+7 IF ($Y+1>MAXCNT)!'IBEPGCNT
DO HEADER
if IBESTOP
QUIT
+8 SET IBETOP0=$GET(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"TOP"))
+9 SET IBTOPST=$PIECE(IBETOP0,"^",4)
SET IBTOPST=$SELECT(IBTOPST:"INACTIVE",1:"ACTIVE")
+10 DO PRINTOP(IBENAME,IBETOPI)
+11 ;
+12 if 'IBEMTOPI
QUIT
+13 IF $GET(IBESUM)=2
Begin DoDot:1
+14 SET IBEMTED=$$NOW^XLFDT
SET IBEMTED=$ORDER(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED),-1)
+15 ; This should always be true, if data came from STS MFS process
IF IBEMTED
Begin DoDot:2
+16 SET IBEMTEDI=""
SET IBEMTEDI=$ORDER(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED,IBEMTEDI))
+17 SET IBEMTST=$PIECE(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS",IBEMTEDI,0),"^",2)
+18 WRITE ?22," PHDSC Status: ",$SELECT(IBEMTST:"ACTIVE",1:"INACTIVE")
End DoDot:2
+19 SET IBEMPAR=$PIECE(IBEMTOP0,"^",3)
IF IBEMPAR
SET IBEMPARX=$PIECE($GET(^IBEMTOP(355.99,IBEMPAR,0)),"^")
+20 IF $LENGTH($GET(IBEMPARX))
WRITE !,"PHDSC Parent: ",IBEMPARX
+21 SET IBEMV0=$GET(^IBEMTOP(355.99,IBEMTOPI,"VUID"))
+22 SET IBEMREPL=$PIECE(IBEMV0,"^",3)
IF IBEMREPL
SET IBEMREPX=$PIECE($GET(^IBEMTOP(355.99,IBEMREPL,0)),"^")
+23 IF $LENGTH($GET(IBEMREPX))
WRITE !,"MTOP PHDSC Replaced By: ",IBEMREPX
End DoDot:1
+24 QUIT
+25 ;
MUA(IBEMUA) ; Select (M)apped, (U)nmapped, or(A)ll - entries from 355.1 mapped to 355.99
+1 NEW DIR,DIRUT,Y
+2 WRITE !
SET DIR(0)="SAO^M:(M)apped;U:(U)nmapped;A:(A)ll"
+3 SET DIR("?")="Enter ^ to exit"
+4 SET DIR("A",1)="Run the report for"
+5 SET DIR("A")="(M)apped, (U)nmapped, or (A)ll Type of Plan entries: "
SET DIR("B")="A"
DO ^DIR
+6 IF $DATA(DIRUT)
SET IBEOUT=1
QUIT
+7 SET IBEMUA=Y
+8 QUIT
+9 ;
SUMMARY() ; ask to print detailed or summary report
+1 NEW DIR,DIRUT,X,Y
+2 SET DIR(0)="SOA^D:Detailed;S:Summary;"
SET DIR("B")="Summary"
+3 SET DIR("A")="Type of report to print: "
+4 WRITE !
DO ^DIR
+5 IF $DATA(DIRUT)
SET IBESTOP=1
QUIT 0
+6 QUIT $SELECT(Y="S":1,Y="D":2,1:0)
+7 ;
OUT() ; select Excel or Report format
+1 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+2 WRITE !
+3 SET DIR(0)="SA^E:Excel;R:Report"
+4 SET DIR("A")="(E)xcel Format or (R)eport Format: "
+5 SET DIR("B")="Report"
+6 DO ^DIR
IF $DATA(DIRUT)
SET IBESTOP=1
QUIT ""
+7 QUIT Y
+8 ;
DELIM(IBENAME,IBETOPI) ; Print output in "^" delimited format
+1 ; Print data in (E)xcel format, e.g., "data^data^data"
+2 NEW IBSTRING,IBABB,IBCATX,IBTOPST
+3 NEW IBMCOD,IBMNAM,IBMSTAT,IBMAP
+4 IF IBCNT=1
Begin DoDot:1
+5 IF IBESUM=2
WRITE !,"TYPE OF PLAN NAME^PLAN ABBREVIATION^PLAN STATUS^MAJOR CATEGORY^MAPPED/NOT MAPPED^MTOP PHDSC NAME^MTOP PHDSC CODE^MTOP PHDSC STATUS^PARENT^REPLACED BY"
+6 IF IBESUM=1
WRITE !,"TYPE OF PLAN NAME^MAPPED/NOT MAPPED^MTOP PHDSC NAME"
End DoDot:1
+7 SET IBETOP0=$GET(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"TOP"))
+8 SET IBTOPST=$PIECE(IBETOP0,"^",4)
SET IBTOPST=$SELECT(IBTOPST:"INACTIVE",1:"ACTIVE")
+9 SET IBABB=$PIECE(IBETOP0,"^",2)
+10 SET IBECT=$PIECE(IBETOP0,"^",3)
Begin DoDot:1
+11 NEW IBECTS,IBERR
+12 SET IBCATX=""
+13 DO FIND^DIC(355.1,,".01;.03","A","`"_+$GET(IBETOPI),,,,,"IBECTS","IBERR")
+14 IF $GET(IBENAME)=$GET(IBECTS("DILIST","ID",1,.01))
SET IBCATX=$GET(IBECTS("DILIST","ID",1,.03))
End DoDot:1
+15 SET IBEMTOP0=$GET(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"MTOP"))
+16 SET IBEMTOPI=+$PIECE(IBEMTOP0,"^",4)
+17 SET IBMNAM=$PIECE(IBEMTOP0,"^")
SET IBMCOD=$PIECE(IBEMTOP0,"^",2)
+18 SET IBMAP=$SELECT(IBEMTOPI:"MAPPED",1:"NOT MAPPED")
+19 IF 'IBEMTOPI
Begin DoDot:1
+20 IF IBESUM=2
SET IBSTRING=IBENAME_"^"_IBABB_"^"_IBTOPST_"^"_IBCATX_"^"_IBMAP
+21 IF IBESUM'=2
SET IBSTRING=IBENAME_"^"_IBMAP
+22 WRITE !,IBSTRING
End DoDot:1
QUIT
+23 SET IBEMTED=$$NOW^XLFDT
SET IBEMTED=$ORDER(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED),-1)
+24 SET IBEMTEDI=""
SET IBEMTEDI=$ORDER(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS","B",IBEMTED,IBEMTEDI))
+25 SET IBEMTST=$PIECE(^IBEMTOP(355.99,IBEMTOPI,"TERMSTATUS",IBEMTEDI,0),"^",2)
+26 SET IBMSTAT=$SELECT(IBEMTST:"ACTIVE",1:"INACTIVE")
+27 SET IBEMPAR=+$PIECE(IBEMTOP0,"^",3)
+28 SET IBEMPARX=$PIECE($GET(^IBEMTOP(355.99,IBEMPAR,0)),"^")
+29 SET IBEMV0=$GET(^IBEMTOP(355.99,IBEMTOPI,"VUID"))
+30 SET IBEMREPL=+$PIECE(IBEMV0,"^",3)
+31 SET IBEMREPX=$PIECE($GET(^IBEMTOP(355.99,IBEMREPL,0)),"^")
+32 IF IBESUM=2
SET IBSTRING=IBENAME_"^"_IBABB_"^"_IBTOPST_"^"_IBCATX_"^"_IBMAP_"^"_IBMNAM_"^"_IBMCOD_"^"_IBMSTAT_"^"_IBEMPARX_"^"_IBEMREPX
+33 IF IBESUM'=2
SET IBSTRING=IBENAME_"^"_IBMAP_"^"_IBMNAM
+34 WRITE !,IBSTRING
+35 QUIT
+36 ;
SELDEV() ; Prompt for output device, return 1 if queued
+1 IF IBEOUTP="E"
Begin DoDot:1
+2 NEW DIR,X,Y
+3 SET DIR("A",1)=""
+4 SET DIR("A",2)=" ************************************************************"
+5 SET DIR("A",3)=" ** You selected a Delimited report. Please verify you **"
+6 SET DIR("A",4)=" ** you have turned logging on to capture the output. **"
+7 SET DIR("A",5)=" ** **"
+8 SET DIR("A",6)=" ** To avoid undesired wrapping, enter '0;199;999' at **"
+9 SET DIR("A",7)=" ** the 'DEVICE:' prompt. The Terminal Session display **"
+10 SET DIR("A",8)=" ** may need to be set to 199 columns. **"
+11 SET DIR("A",9)=" ************************************************************"
+12 SET DIR("A",10)=""
+13 SET DIR("A",11)=""
SET DIR("A",12)=""
+14 SET DIR("A")=" Press return to continue"
+15 SET DIR(0)="EA"
DO ^DIR
WRITE !
End DoDot:1
+16 ;
+17 NEW IBEDONE
+18 WRITE !,"You may queue this report to print at a later time.",!
+19 FOR
if $GET(IBESTOP)!$GET(IBEDONE)
QUIT
Begin DoDot:1
+20 KILL %ZIS,IOP,POP,ZTSK
NEW I
SET IBEION=$IO
SET %ZIS="QM"
+21 DO ^%ZIS
KILL %ZIS
+22 IF POP
SET IOP=IBEION
DO ^%ZIS
KILL IOP,IBEION
Begin DoDot:2
+23 NEW DIR,X,Y
+24 SET DIR(0)="YA"
SET DIR("A",1)=" ** No Device Selected **"
SET DIR("A")="Select a different device? (Y/N) "
DO ^DIR
+25 if 'Y
SET IBESTOP=1
End DoDot:2
QUIT
+26 SET IBEDONE=1
End DoDot:1
+27 IF $DATA(IO("Q"))
Begin DoDot:1
+28 NEW ZTDESC,ZTSAVE,ZTRTN
+29 SET ZTDESC="Type of Plan to MTOP Mapping Report"
SET ZTRTN="DQ^IBENDS1"
+30 SET ZTSAVE("DATE*")=""
SET ZTSAVE("IBE*")=""
SET ZTSAVE("ZTREQ")="@"
+31 KILL IO("Q")
DO ^%ZTLOAD
if $DATA(ZTSK)
WRITE !,"Report is Queued to print!"
KILL ZTSK
End DoDot:1
QUIT 1
+32 if $GET(IBESTOP)
QUIT -1
+33 QUIT 0
+34 ;
+1 NEW IBEHDR,IBETAB,IBESPACE
+2 SET IBESTOP=0
+3 IF CRT
IF IBEPGCNT>0
IF '$DATA(ZTQUEUED)
Begin DoDot:1
+4 NEW DIR,LIN
+5 IF MAXCNT<51
FOR LIN=1:1:(MAXCNT-$Y)
WRITE !
+6 WRITE !
+7 SET DIR(0)="E"
DO ^DIR
KILL DIR
+8 IF 'Y
SET IBESTOP=1
QUIT
End DoDot:1
if IBESTOP
QUIT
+9 SET IBEPGCNT=IBEPGCNT+1
+10 WRITE @IOF,!
+11 SET $PIECE(IBESPACE," ",132)=""
+12 SET IBEHDR=" Type Of Plan Map to Master Type of Plan (MTOP) "
+13 SET IBEHDR(1)=" PHDSC Source of Payment Typology Report"
+14 SET IBEHDR=IBEHDR_"Page: "_IBEPGCNT
SET IBETAB=132-$LENGTH(IBEHDR)-1
+15 WRITE IBEHDR
+16 WRITE !,IBEHDR(1)
+17 QUIT
+18 ;
PRINTOP(IBENAME,IBETOPI) ; Print Type of Plan file (#355.1) entry
+1 WRITE !!,"Type of Plan: ",$PIECE(IBETOP0,"^")
+2 IF $GET(IBESUM)=2
Begin DoDot:1
+3 WRITE !,"Abbreviation: ",$PIECE(IBETOP0,"^",2)
+4 WRITE ?30,"Status: ",IBTOPST
+5 SET IBECT=$PIECE(IBETOP0,"^",3)
IF $LENGTH(IBECT)
Begin DoDot:2
+6 DO FIELD^DID(355.1,.03,"","POINTER","IBECTS")
+7 SET IBECTX=$PIECE(IBECTS("POINTER"),+IBECT_":",2)
SET IBECTX=$PIECE(IBECTX,";")
+8 IF $LENGTH(IBECTX)
WRITE !?4,"Category: ",IBECTX
End DoDot:2
End DoDot:1
+9 SET IBEMTOP0=$GET(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"MTOP"))
+10 SET IBEMTOPI=+$PIECE(IBEMTOP0,"^",4)
+11 WRITE !?2,"Mapped to PHDSC Source of Payment?: ",$SELECT(IBEMTOPI:"YES",1:"NO")
+12 if 'IBEMTOPI
QUIT
+13 WRITE !?2,"PHDSC Name: ",$PIECE(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"MTOP"),"^")
+14 WRITE !?2,"PHDSC Code: ",$PIECE(^TMP($JOB,"IBENDS1",IBENAME,IBETOPI,"MTOP"),"^",2)
+15 QUIT
