BCSVMR2 ;IHS/MSC/PLS - CSV Mapping Report;28-Jul-2008 12:55;AA
;;1.0;BCSV;;APR 23, 2010
;=================================================================
Q
EN ; EP - Generate mapping status report.
N POP,UNMAPF,MAPF
W !,"Mapping Report for Code Set Versioning Project - Phase One",!!
D ENVCHK
D PARAM
D DEVICE
Q:POP
D TASK
Q
;
TASK ;EP
N ZTRTN,ZTDTH,ZTDESC
S ZTRTN="OUTPUT^BCSVMR2"
I $G(IO("Q")) D
.S ZTDTH=$H
.S ZTDESC="CSV Field Mapping Report"
.S ZTIO=ION
.S ZTSAVE("UNMAPF")="",ZTSAVE("MAPF")=""
.D ^%ZTLOAD
E D @ZTRTN
D ^%ZISC
Q
; Generate report
OUTPUT ;
N SIZE,FLAGQ,FLAGP,FLAGE,FIL,LP,DLM,DDLM,EFLG,OFF,SRC,TRG
N DASH,DOT,EQUAL,RPTDATE,Z1,ARW
S SIZE=IOSL-5,FLAGP=1,ARW="=>"
D INIT^BCSVMP
S $P(DASH,"-",212)=""
S $P(DOT,".",106)=""
S $P(EQUAL,"=",212)=""
F D Q:$G(EFLG)!$G(FLAGE)
.S FIL=$$NXTFIL^BCSVMP(.OFF)
.I $P(FIL,DDLM,2)="" S EFLG=1 Q
.S FLAGQ=0
.D SETFILE^BCSVMP($P(FIL,DDLM,2),.SRC,.TRG)
.D PT(SRC("NUM"),SRC("FNAM"))
.S HD="" D PAGE
Q
; Returns status of environment
ENVCHK Q
; Collects parameters
PARAM ;
S UNMAPF=1,MAPF=1
W !,"WARNING: Printing mapped items will consume a lot of paper",!
S UNMAPF=$$YN^BCSVMP("N","Include list of unmapped items")
S MAPF=$$YN^BCSVMP("N","Include list of mapped items")
I MAPF=1 D
.K RPTTYP
.N DIR,Y
.S DIR(0)="S^A:AUTOMAPPED;M:MANUALLY MAPPED;B:BOTH"
.S DIR("B")="B"
.S DIR("A")="What do you want to include"
.D ^DIR
.S RPTTYP=Y
W !
Q
; Prompts for output device
DEVICE ;
N %ZIS
S %ZIS="Q",%ZIS("A")="Select device for mapping report: "
D ^%ZIS
Q
; Pointers to the file
PT(FNUM,FNAM) ;EP
N FILE,FLD,ZGL,ZCNT,FILEN,ZFILE,ZGLCNT
S ZGL=^DIC(FNUM,0,"GL")
;S ZGLCNT=$G(@(ZGL_"0)")),ZGLCNT=$S($P(ZGLCNT,U,4)]"":$P(ZGLCNT,U,4),1:"No Entries")
S ZGLCNT=$$GLOBCNT(ZGL) I 'ZGLCNT S ZGLCNT="No Entries"
D INIT7 G:FLAGQ EX D HDRP S FILE="",ZCNT=1,HD="HDRP"
I '$D(^DD(FNUM,0,"PT")) W ?30,"No files point to the "_FNAM_" file." Q
F S FILE=$O(^DD(FNUM,0,"PT",FILE)) Q:FILE=""!FLAGQ D
.S FLAGPT=0 D @$S($D(^DIC(FILE,0)):"PTYES",1:"PTNO")
.I 'FLAGPT S FLD="" F S FLD=$O(^DD(FNUM,0,"PT",FILE,FLD)) Q:FLD="" D Q:FLAGQ!$G(FLAGE)
..D PTPRT Q:FLAGQ
S HD="" D PAGE
I '$G(FLAGE)&'FLAGQ D
.D:UNMAPF UNMAP(SRC("GNAM"))
.Q:$G(FLAGE)!FLAGQ
.D PAUSE
.Q:$G(FLAGE)!FLAGQ
.D:MAPF MAP(SRC("GNAM"))
K FLAGPT
Q
; Get true global entry count
GLOBCNT(GBL) ;
N LOOP,IEN,GCNT
S GCNT=0
S LOOP=GBL_"IEN)"
S IEN=0 F S IEN=$O(@LOOP) Q:'IEN D
.S GCNT=GCNT+1
Q GCNT
PTNO ;
I '$D(^DD(FILE,0,"UP")) S FLAGPT=1 Q
S FILETP=FILE F S FILETP=^DD(FILETP,0,"UP") Q:$D(^DIC(FILETP,0)) I '$D(^DD(FILETP,0,"UP")) Q
I '$D(^DIC(FILETP,0)) S FLAGPT=1 Q
S GL=^DIC(FILETP,0,"GL"),FILEN=$P(^DIC(FILETP,0),U)
Q
PTYES S GL=^DIC(FILE,0,"GL"),FILEN=$P(^DIC(FILE,0),U)
Q
PTPRT ;
N KNWPTR
S KNWPTR=$S($$KNWNPTR^BCSVMP(TRG("GNAM"),FILE,FLD):" ",1:"#")
W !,$J(ZCNT,4),".",?6,GL,?21,$E(FILEN,1,25)
W ?47 I $D(^DD(FILE,FLD,0)),$P(^(0),U)]"" W KNWPTR_$E($P(^(0),U),1,22)," (",FLD,")"
E W "--> Field ",FLD," does not exist."
S ZCNT=ZCNT+1 I $Y>SIZE D PAGE
Q
; Output unmapped items
UNMAP(FIL) ;
N SIEN,GLBP,SOURCE,I
D HDRU S HD="HDRU"
S GLBP=$S(FIL="AUTTCMOD":$$GLBPATH^BCSVMP(TRG("GNAM"),"UNMAP"),1:$$GLBPATH^BCSVMP(SRC("GNAM"),"UNMAP"))
I '$$MAPCNT^BCSVMP($S(FIL="AUTTCMOD":TRG("GNAM"),1:SRC("GNAM")),"UNMAP") W !,"There are no unmapped entries." Q
S SIEN=0 F S SIEN=$O(@GLBP@(SIEN)) Q:'SIEN D Q:FLAGQ
.Q:$$PSTCSVCD(SIEN)=1 ;IHS/SD/SDR 4/14/09
.S SDESC=$$GDESC^BCSVMP("S",SRC("NUM"),+SIEN,SRC("DFLD"),1)
.D BLDARY("SOURCE",SDESC)
.W !,?2,"*"
.S I=0 F S I=$O(SOURCE(I)) Q:'I D
..W ?4,$G(SOURCE(I)) I $O(SOURCE(I)) W !
.D INAFLAG(SIEN)
.I $Y>SIZE D PAGE Q:FLAGQ
.W !
Q
;start new code IHS/SD/SDR 4/14/09
;check if code was added after 10/1/08; if so, skip it
PSTCSVCD(SIEN) ;
;CPT
S BCSVF=0
I SRC("NUM")=81 D
.I $$VERSION^XPDUTL("BCSV")>0 D
..I $P($G(^ICPT(SIEN,9999999)),U,6)>3080930 S BCSVF=1
.I +$$VERSION^XPDUTL("BCSV")=0 D
..I $P($G(^ICPT(SIEN,0)),U,6)>3080930 S BCSVF=1
;ICD0
I SRC("NUM")=80.1 D
.I $P($G(^ICD0(SIEN,9999999)),U,4)>3080930 S BCSVF=1
;ICD9
I SRC("NUM")=80 D
.I $P($G(^ICD9(SIEN,9999999)),U,4)>3080930 S BCSVF=1
Q BCSVF
;end new code 4/14/09
;start new code 6/25/09
INAFLAG(SIEN) ;
;CPT
I +$G(SIEN)=0 Q
S SIFLG=0
I SRC("NUM")=81 D
.S SIFLG=$$GET1^DIQ(81,SIEN,7,"I")
;ICD0
I SRC("NUM")=80.1 D
.S SIFLG=$$GET1^DIQ(80.1,SIEN,102,"I")
;ICD9
I SRC("NUM")=80 D
.S SIFLG=$$GET1^DIQ(80,SIEN,102,"I")
;
I SIFLG W " (INACTIVE)"
Q
;end new code 6/25/09
; Output mapped items IHS === VA
MAP(FIL) ;
N SIEN,TIEN,GLBP,SOURCE,TARGET,I
D HDRM S HD="HDRM"
;S GLBP=$$GLBPATH^BCSVMP(SRC("GNAM"),"MAP")
S GLBP=$S(FIL="AUTTCMOD":$$GLBPATH^BCSVMP(TRG("GNAM"),"MAP"),1:$$GLBPATH^BCSVMP(SRC("GNAM"),"MAP"))
;I '$$MAPCNT^BCSVMP(SRC("GNAM"),"MAP") W !,"There are no mapped entries." Q
I '$$MAPCNT^BCSVMP($S(FIL="AUTTCMOD":TRG("GNAM"),1:SRC("GNAM")),"MAP") W !,"There are no mapped entries." Q
S SIEN=0 F S SIEN=$O(@GLBP@(SIEN)) Q:'SIEN D Q:FLAGQ
.I ($G(RPTTYP)="A"!($G(RPTTYP)="M"))&($P($G(@GLBP@(SIEN)),U,2)'=RPTTYP) Q ;only do auto/manually mapped
.S SDESC=$$GDESC^BCSVMP("S",SRC("NUM"),+SIEN,SRC("DFLD"),1)
.S TDESC=$$GDESC^BCSVMP("T",$$GLBPATH^BCSVMP(TRG("GNAM"),"DATA"),+@$$GLBPATH^BCSVMP(TRG("GNAM"),"MAP")@(+SIEN),TRG("DFLD"),1)
.;I $L(SDESC)>30 D
.;.W !,?2,SDESC,?35,ARW
.;.I $Y>SIZE D PAGE Q:FLAGQ
.;.W !,?10,TDESC
.;E W !,?2,SDESC,?46,TDESC
.D BLDARY("SOURCE",SDESC)
.W !,?1,"*"
.S I=0 F S I=$O(SOURCE(I)) Q:'I D
..W ?4,$G(SOURCE(I)) I $O(SOURCE(I)) W !
.W " ("_$P($G(@GLBP@(SIEN)),U,2)_")"
.D BLDARY("TARGET",TDESC)
.W !,ARW
.S I=0 F S I=$O(TARGET(I)) Q:'I D
..W ?4,$G(TARGET(I)) I $O(SOURCE(I)) W !
.I $Y>SIZE D PAGE Q:FLAGQ
.W !
Q
; Input ARY - name of array where to store data
; DESC - description as gathered from $$GDESC^BCSVMP
BLDARY(ARY,DESC) ;
N WORD,STRING,I,LINE,NDESC
K @ARY
S STRING="",LINE=1
I $L(DESC)<70 S @ARY@(LINE)=DESC Q
S NDESC=$P(DESC," ")_" // "_$P(DESC," ",2),DESC=NDESC
F I=1:1 D Q:'$L(WORD)
.S WORD=$P(DESC," ",I)
.I '$L(WORD),$L(STRING)>0 S @ARY@(LINE)=$G(STRING) Q
.Q:WORD="//"
.I ($L(STRING)+$L(WORD)+1<70)!($L(STRING)+$L(WORD)+1=70) D Q
..S STRING=$G(STRING)_$S($L(STRING)=0:"",1:" ")_WORD
.E D
..S @ARY@(LINE)=$G(STRING),LINE=LINE+1,STRING=""
.I ($L(WORD)<70)!($L(WORD)=70) S STRING=WORD Q
.E D
..S @ARY@(LINE)=$E(WORD,1,70),LINE=LINE+1
..S @ARY@(LINE)=$E(WORD,71,140),LINE=LINE+1
;I DESC["NON-INVASIVE PERIPHERAL VASCULAR DIAGNOSTIC STUDIES" S A=B
Q
HDR ;
W @IOF Q:'FLAGP W:IO'=IO(0) !!
I '$D(RPTDATE) S RPTDATE=$$FMTE^XLFDT($$DT^XLFDT(),"2Z")
W !,$E(EQUAL,1,IOM)
W !?2,"File:---- ",FNAM," (",FNUM,")"
W !?2,"Global:-- ",ZGL,?(IOM-17),"Date: ",RPTDATE
W !?2,"Total Entries: ",ZGLCNT,?30,"Mapped: ",$$MAPCNT^BCSVMP(TRG("GNAM"),"MAP"),?50,"Unmapped: ",$$MAPCNT^BCSVMP(TRG("GNAM"),"UNMAP")
W !,$E(EQUAL,1,IOM),!
Q
HDRP ;
W !?3,"Pointers TO the "_FNAM_" ("_FNUM_") file.."
W !?5,"A # indicates that the field is a LOCAL pointer."
W !?9,"GLOBAL",?22,"FILE (Truncated to 25)",?50,"FIELD (Truncated to 22)"
W !?6,"-------------",?21,"-------------------------",?48,"------------------------------"
Q
HDRU ; Unmapped items header
W @IOF Q:'FLAGP W:IO'=IO(0) !!
W !,$E(EQUAL,1,IOM)
W !,"The following entries have not been mapped to the VA codes."
W !," IHS Value"
W !,$E(EQUAL,1,IOM),!
Q
HDRM ; Mapped Items header
W @IOF Q:'FLAGP W:IO'=IO(0) !!
W !,$E(EQUAL,1,IOM)
W !,"The following items are mapped."
W !," * IHS Value"
W !," => VA Value"
W !,$E(EQUAL,1,IOM),!
Q
PAGE ;
Q:FLAGQ
N I F I=$Y:1:SIZE W !
I FLAGP,IO'=IO(0)!($D(ZTQUEUED)) W @IOF,!!! D:HD'="" @HD Q
R !!?2,"<RETURN> to continue, '^' to quit, '^^' to exit: ",Z1:DTIME
S:'$T Z1=U
I Z1[U S FLAGQ=1 S:Z1="^^" FLAGE=1
W:'$G(FLAGE) @IOF
Q:FLAGQ!($D(FLAGE))
D:$L(HD) @HD
Q
PAUSE ;
;
Q
INIT7 ;
;I FLAGP,IO=IO(0),IOSL>25,IOST["C-" D SCROLL Q:FLAGQ
I FLAGP U IO ;W:IO'=IO(0) "Printing.."
D HDR Q
EX ;
K FLAGPT,^UTILITY($J,"GROUP")
Q
SCROLL ;Adjust scroll rate
W !!?8,"SCROLLING: [N]ormal [S]mooth . . . . ","Select: N//"
R SCROLL:DTIME S:'$T SCROLL="^" S SCROLL=$E(SCROLL) I SCROLL="^" S FLAGQ=1 Q
I SCROLL="?" W !?8,"Since you're printing to your CRT and you've asked for a page",!?8,"length greater than 25, you may now adjust the scroll rate.",!?8,"For DEC VT-100 compatible devices only." G SCROLL
S:SCROLL="" SCROLL="N" Q:"S,s"'[SCROLL S FLAGS=1 W *27,"[?4h"
Q
BCSVMR2 ;IHS/MSC/PLS - CSV Mapping Report;28-Jul-2008 12:55;AA
+1 ;;1.0;BCSV;;APR 23, 2010
+2 ;=================================================================
+3 QUIT
EN ; EP - Generate mapping status report.
+1 NEW POP,UNMAPF,MAPF
+2 WRITE !,"Mapping Report for Code Set Versioning Project - Phase One",!!
+3 DO ENVCHK
+4 DO PARAM
+5 DO DEVICE
+6 IF POP
QUIT
+7 DO TASK
+8 QUIT
+9 ;
TASK ;EP
+1 NEW ZTRTN,ZTDTH,ZTDESC
+2 SET ZTRTN="OUTPUT^BCSVMR2"
+3 IF $GET(IO("Q"))
Begin DoDot:1
+4 SET ZTDTH=$HOROLOG
+5 SET ZTDESC="CSV Field Mapping Report"
+6 SET ZTIO=ION
+7 SET ZTSAVE("UNMAPF")=""
SET ZTSAVE("MAPF")=""
+8 DO ^%ZTLOAD
End DoDot:1
+9 IF '$TEST
DO @ZTRTN
+10 DO ^%ZISC
+11 QUIT
+12 ; Generate report
OUTPUT ;
+1 NEW SIZE,FLAGQ,FLAGP,FLAGE,FIL,LP,DLM,DDLM,EFLG,OFF,SRC,TRG
+2 NEW DASH,DOT,EQUAL,RPTDATE,Z1,ARW
+3 SET SIZE=IOSL-5
SET FLAGP=1
SET ARW="=>"
+4 DO INIT^BCSVMP
+5 SET $PIECE(DASH,"-",212)=""
+6 SET $PIECE(DOT,".",106)=""
+7 SET $PIECE(EQUAL,"=",212)=""
+8 FOR
Begin DoDot:1
+9 SET FIL=$$NXTFIL^BCSVMP(.OFF)
+10 IF $PIECE(FIL,DDLM,2)=""
SET EFLG=1
QUIT
+11 SET FLAGQ=0
+12 DO SETFILE^BCSVMP($PIECE(FIL,DDLM,2),.SRC,.TRG)
+13 DO PT(SRC("NUM"),SRC("FNAM"))
+14 SET HD=""
DO PAGE
End DoDot:1
IF $GET(EFLG)!$GET(FLAGE)
QUIT
+15 QUIT
+16 ; Returns status of environment
ENVCHK QUIT
+1 ; Collects parameters
PARAM ;
+1 SET UNMAPF=1
SET MAPF=1
+2 WRITE !,"WARNING: Printing mapped items will consume a lot of paper",!
+3 SET UNMAPF=$$YN^BCSVMP("N","Include list of unmapped items")
+4 SET MAPF=$$YN^BCSVMP("N","Include list of mapped items")
+5 IF MAPF=1
Begin DoDot:1
+6 KILL RPTTYP
+7 NEW DIR,Y
+8 SET DIR(0)="S^A:AUTOMAPPED;M:MANUALLY MAPPED;B:BOTH"
+9 SET DIR("B")="B"
+10 SET DIR("A")="What do you want to include"
+11 DO ^DIR
+12 SET RPTTYP=Y
End DoDot:1
+13 WRITE !
+14 QUIT
+15 ; Prompts for output device
DEVICE ;
+1 NEW %ZIS
+2 SET %ZIS="Q"
SET %ZIS("A")="Select device for mapping report: "
+3 DO ^%ZIS
+4 QUIT
+5 ; Pointers to the file
PT(FNUM,FNAM) ;EP
+1 NEW FILE,FLD,ZGL,ZCNT,FILEN,ZFILE,ZGLCNT
+2 SET ZGL=^DIC(FNUM,0,"GL")
+3 ;S ZGLCNT=$G(@(ZGL_"0)")),ZGLCNT=$S($P(ZGLCNT,U,4)]"":$P(ZGLCNT,U,4),1:"No Entries")
+4 SET ZGLCNT=$$GLOBCNT(ZGL)
IF 'ZGLCNT
SET ZGLCNT="No Entries"
+5 DO INIT7
IF FLAGQ
GOTO EX
DO HDRP
SET FILE=""
SET ZCNT=1
SET HD="HDRP"
+6 IF '$DATA(^DD(FNUM,0,"PT"))
WRITE ?30,"No files point to the "_FNAM_" file."
QUIT
+7 FOR
SET FILE=$ORDER(^DD(FNUM,0,"PT",FILE))
IF FILE=""!FLAGQ
QUIT
Begin DoDot:1
+8 SET FLAGPT=0
DO @$SELECT($DATA(^DIC(FILE,0)):"PTYES",1:"PTNO")
+9 IF 'FLAGPT
SET FLD=""
FOR
SET FLD=$ORDER(^DD(FNUM,0,"PT",FILE,FLD))
IF FLD=""
QUIT
Begin DoDot:2
+10 DO PTPRT
IF FLAGQ
QUIT
End DoDot:2
IF FLAGQ!$GET(FLAGE)
QUIT
End DoDot:1
+11 SET HD=""
DO PAGE
+12 IF '$GET(FLAGE)&'FLAGQ
Begin DoDot:1
+13 IF UNMAPF
DO UNMAP(SRC("GNAM"))
+14 IF $GET(FLAGE)!FLAGQ
QUIT
+15 DO PAUSE
+16 IF $GET(FLAGE)!FLAGQ
QUIT
+17 IF MAPF
DO MAP(SRC("GNAM"))
End DoDot:1
+18 KILL FLAGPT
+19 QUIT
+20 ; Get true global entry count
GLOBCNT(GBL) ;
+1 NEW LOOP,IEN,GCNT
+2 SET GCNT=0
+3 SET LOOP=GBL_"IEN)"
+4 SET IEN=0
FOR
SET IEN=$ORDER(@LOOP)
IF 'IEN
QUIT
Begin DoDot:1
+5 SET GCNT=GCNT+1
End DoDot:1
+6 QUIT GCNT
PTNO ;
+1 IF '$DATA(^DD(FILE,0,"UP"))
SET FLAGPT=1
QUIT
+2 SET FILETP=FILE
FOR
SET FILETP=^DD(FILETP,0,"UP")
IF $DATA(^DIC(FILETP,0))
QUIT
IF '$DATA(^DD(FILETP,0,"UP"))
QUIT
+3 IF '$DATA(^DIC(FILETP,0))
SET FLAGPT=1
QUIT
+4 SET GL=^DIC(FILETP,0,"GL")
SET FILEN=$PIECE(^DIC(FILETP,0),U)
+5 QUIT
PTYES SET GL=^DIC(FILE,0,"GL")
SET FILEN=$PIECE(^DIC(FILE,0),U)
+1 QUIT
PTPRT ;
+1 NEW KNWPTR
+2 SET KNWPTR=$SELECT($$KNWNPTR^BCSVMP(TRG("GNAM"),FILE,FLD):" ",1:"#")
+3 WRITE !,$JUSTIFY(ZCNT,4),".",?6,GL,?21,$EXTRACT(FILEN,1,25)
+4 WRITE ?47
IF $DATA(^DD(FILE,FLD,0))
IF $PIECE(^(0),U)]""
WRITE KNWPTR_$EXTRACT($PIECE(^(0),U),1,22)," (",FLD,")"
+5 IF '$TEST
WRITE "--> Field ",FLD," does not exist."
+6 SET ZCNT=ZCNT+1
IF $Y>SIZE
DO PAGE
+7 QUIT
+8 ; Output unmapped items
UNMAP(FIL) ;
+1 NEW SIEN,GLBP,SOURCE,I
+2 DO HDRU
SET HD="HDRU"
+3 SET GLBP=$SELECT(FIL="AUTTCMOD":$$GLBPATH^BCSVMP(TRG("GNAM"),"UNMAP"),1:$$GLBPATH^BCSVMP(SRC("GNAM"),"UNMAP"))
+4 IF '$$MAPCNT^BCSVMP($SELECT(FIL="AUTTCMOD":TRG("GNAM"),1:SRC("GNAM")),"UNMAP")
WRITE !,"There are no unmapped entries."
QUIT
+5 SET SIEN=0
FOR
SET SIEN=$ORDER(@GLBP@(SIEN))
IF 'SIEN
QUIT
Begin DoDot:1
+6 ;IHS/SD/SDR 4/14/09
IF $$PSTCSVCD(SIEN)=1
QUIT
+7 SET SDESC=$$GDESC^BCSVMP("S",SRC("NUM"),+SIEN,SRC("DFLD"),1)
+8 DO BLDARY("SOURCE",SDESC)
+9 WRITE !,?2,"*"
+10 SET I=0
FOR
SET I=$ORDER(SOURCE(I))
IF 'I
QUIT
Begin DoDot:2
+11 WRITE ?4,$GET(SOURCE(I))
IF $ORDER(SOURCE(I))
WRITE !
End DoDot:2
+12 DO INAFLAG(SIEN)
+13 IF $Y>SIZE
DO PAGE
IF FLAGQ
QUIT
+14 WRITE !
End DoDot:1
IF FLAGQ
QUIT
+15 QUIT
+16 ;start new code IHS/SD/SDR 4/14/09
+17 ;check if code was added after 10/1/08; if so, skip it
PSTCSVCD(SIEN) ;
+1 ;CPT
+2 SET BCSVF=0
+3 IF SRC("NUM")=81
Begin DoDot:1
+4 IF $$VERSION^XPDUTL("BCSV")>0
Begin DoDot:2
+5 IF $PIECE($GET(^ICPT(SIEN,9999999)),U,6)>3080930
SET BCSVF=1
End DoDot:2
+6 IF +$$VERSION^XPDUTL("BCSV")=0
Begin DoDot:2
+7 IF $PIECE($GET(^ICPT(SIEN,0)),U,6)>3080930
SET BCSVF=1
End DoDot:2
End DoDot:1
+8 ;ICD0
+9 IF SRC("NUM")=80.1
Begin DoDot:1
+10 IF $PIECE($GET(^ICD0(SIEN,9999999)),U,4)>3080930
SET BCSVF=1
End DoDot:1
+11 ;ICD9
+12 IF SRC("NUM")=80
Begin DoDot:1
+13 IF $PIECE($GET(^ICD9(SIEN,9999999)),U,4)>3080930
SET BCSVF=1
End DoDot:1
+14 QUIT BCSVF
+15 ;end new code 4/14/09
+16 ;start new code 6/25/09
INAFLAG(SIEN) ;
+1 ;CPT
+2 IF +$GET(SIEN)=0
QUIT
+3 SET SIFLG=0
+4 IF SRC("NUM")=81
Begin DoDot:1
+5 SET SIFLG=$$GET1^DIQ(81,SIEN,7,"I")
End DoDot:1
+6 ;ICD0
+7 IF SRC("NUM")=80.1
Begin DoDot:1
+8 SET SIFLG=$$GET1^DIQ(80.1,SIEN,102,"I")
End DoDot:1
+9 ;ICD9
+10 IF SRC("NUM")=80
Begin DoDot:1
+11 SET SIFLG=$$GET1^DIQ(80,SIEN,102,"I")
End DoDot:1
+12 ;
+13 IF SIFLG
WRITE " (INACTIVE)"
+14 QUIT
+15 ;end new code 6/25/09
+16 ; Output mapped items IHS === VA
MAP(FIL) ;
+1 NEW SIEN,TIEN,GLBP,SOURCE,TARGET,I
+2 DO HDRM
SET HD="HDRM"
+3 ;S GLBP=$$GLBPATH^BCSVMP(SRC("GNAM"),"MAP")
+4 SET GLBP=$SELECT(FIL="AUTTCMOD":$$GLBPATH^BCSVMP(TRG("GNAM"),"MAP"),1:$$GLBPATH^BCSVMP(SRC("GNAM"),"MAP"))
+5 ;I '$$MAPCNT^BCSVMP(SRC("GNAM"),"MAP") W !,"There are no mapped entries." Q
+6 IF '$$MAPCNT^BCSVMP($SELECT(FIL="AUTTCMOD":TRG("GNAM"),1:SRC("GNAM")),"MAP")
WRITE !,"There are no mapped entries."
QUIT
+7 SET SIEN=0
FOR
SET SIEN=$ORDER(@GLBP@(SIEN))
IF 'SIEN
QUIT
Begin DoDot:1
+8 ;only do auto/manually mapped
IF ($GET(RPTTYP)="A"!($GET(RPTTYP)="M"))&($PIECE($GET(@GLBP@(SIEN)),U,2)'=RPTTYP)
QUIT
+9 SET SDESC=$$GDESC^BCSVMP("S",SRC("NUM"),+SIEN,SRC("DFLD"),1)
+10 SET TDESC=$$GDESC^BCSVMP("T",$$GLBPATH^BCSVMP(TRG("GNAM"),"DATA"),+@$$GLBPATH^BCSVMP(TRG("GNAM"),"MAP")@(+SIEN),TRG("DFLD"),1)
+11 ;I $L(SDESC)>30 D
+12 ;.W !,?2,SDESC,?35,ARW
+13 ;.I $Y>SIZE D PAGE Q:FLAGQ
+14 ;.W !,?10,TDESC
+15 ;E W !,?2,SDESC,?46,TDESC
+16 DO BLDARY("SOURCE",SDESC)
+17 WRITE !,?1,"*"
+18 SET I=0
FOR
SET I=$ORDER(SOURCE(I))
IF 'I
QUIT
Begin DoDot:2
+19 WRITE ?4,$GET(SOURCE(I))
IF $ORDER(SOURCE(I))
WRITE !
End DoDot:2
+20 WRITE " ("_$PIECE($GET(@GLBP@(SIEN)),U,2)_")"
+21 DO BLDARY("TARGET",TDESC)
+22 WRITE !,ARW
+23 SET I=0
FOR
SET I=$ORDER(TARGET(I))
IF 'I
QUIT
Begin DoDot:2
+24 WRITE ?4,$GET(TARGET(I))
IF $ORDER(SOURCE(I))
WRITE !
End DoDot:2
+25 IF $Y>SIZE
DO PAGE
IF FLAGQ
QUIT
+26 WRITE !
End DoDot:1
IF FLAGQ
QUIT
+27 QUIT
+28 ; Input ARY - name of array where to store data
+29 ; DESC - description as gathered from $$GDESC^BCSVMP
BLDARY(ARY,DESC) ;
+1 NEW WORD,STRING,I,LINE,NDESC
+2 KILL @ARY
+3 SET STRING=""
SET LINE=1
+4 IF $LENGTH(DESC)<70
SET @ARY@(LINE)=DESC
QUIT
+5 SET NDESC=$PIECE(DESC," ")_" // "_$PIECE(DESC," ",2)
SET DESC=NDESC
+6 FOR I=1:1
Begin DoDot:1
+7 SET WORD=$PIECE(DESC," ",I)
+8 IF '$LENGTH(WORD)
IF $LENGTH(STRING)>0
SET @ARY@(LINE)=$GET(STRING)
QUIT
+9 IF WORD="//"
QUIT
+10 IF ($LENGTH(STRING)+$LENGTH(WORD)+1<70)!($LENGTH(STRING)+$LENGTH(WORD)+1=70)
Begin DoDot:2
+11 SET STRING=$GET(STRING)_$SELECT($LENGTH(STRING)=0:"",1:" ")_WORD
End DoDot:2
QUIT
+12 IF '$TEST
Begin DoDot:2
+13 SET @ARY@(LINE)=$GET(STRING)
SET LINE=LINE+1
SET STRING=""
End DoDot:2
+14 IF ($LENGTH(WORD)<70)!($LENGTH(WORD)=70)
SET STRING=WORD
QUIT
+15 IF '$TEST
Begin DoDot:2
+16 SET @ARY@(LINE)=$EXTRACT(WORD,1,70)
SET LINE=LINE+1
+17 SET @ARY@(LINE)=$EXTRACT(WORD,71,140)
SET LINE=LINE+1
End DoDot:2
End DoDot:1
IF '$LENGTH(WORD)
QUIT
+18 ;I DESC["NON-INVASIVE PERIPHERAL VASCULAR DIAGNOSTIC STUDIES" S A=B
+19 QUIT
HDR ;
+1 WRITE @IOF
IF 'FLAGP
QUIT
IF IO'=IO(0)
WRITE !!
+2 IF '$DATA(RPTDATE)
SET RPTDATE=$$FMTE^XLFDT($$DT^XLFDT(),"2Z")
+3 WRITE !,$EXTRACT(EQUAL,1,IOM)
+4 WRITE !?2,"File:---- ",FNAM," (",FNUM,")"
+5 WRITE !?2,"Global:-- ",ZGL,?(IOM-17),"Date: ",RPTDATE
+6 WRITE !?2,"Total Entries: ",ZGLCNT,?30,"Mapped: ",$$MAPCNT^BCSVMP(TRG("GNAM"),"MAP"),?50,"Unmapped: ",$$MAPCNT^BCSVMP(TRG("GNAM"),"UNMAP")
+7 WRITE !,$EXTRACT(EQUAL,1,IOM),!
+8 QUIT
HDRP ;
+1 WRITE !?3,"Pointers TO the "_FNAM_" ("_FNUM_") file.."
+2 WRITE !?5,"A # indicates that the field is a LOCAL pointer."
+3 WRITE !?9,"GLOBAL",?22,"FILE (Truncated to 25)",?50,"FIELD (Truncated to 22)"
+4 WRITE !?6,"-------------",?21,"-------------------------",?48,"------------------------------"
+5 QUIT
HDRU ; Unmapped items header
+1 WRITE @IOF
IF 'FLAGP
QUIT
IF IO'=IO(0)
WRITE !!
+2 WRITE !,$EXTRACT(EQUAL,1,IOM)
+3 WRITE !,"The following entries have not been mapped to the VA codes."
+4 WRITE !," IHS Value"
+5 WRITE !,$EXTRACT(EQUAL,1,IOM),!
+6 QUIT
HDRM ; Mapped Items header
+1 WRITE @IOF
IF 'FLAGP
QUIT
IF IO'=IO(0)
WRITE !!
+2 WRITE !,$EXTRACT(EQUAL,1,IOM)
+3 WRITE !,"The following items are mapped."
+4 WRITE !," * IHS Value"
+5 WRITE !," => VA Value"
+6 WRITE !,$EXTRACT(EQUAL,1,IOM),!
+7 QUIT
PAGE ;
+1 IF FLAGQ
QUIT
+2 NEW I
FOR I=$Y:1:SIZE
WRITE !
+3 IF FLAGP
IF IO'=IO(0)!($DATA(ZTQUEUED))
WRITE @IOF,!!!
IF HD'=""
DO @HD
QUIT
+4 READ !!?2,"<RETURN> to continue, '^' to quit, '^^' to exit: ",Z1:DTIME
+5 IF '$TEST
SET Z1=U
+6 IF Z1[U
SET FLAGQ=1
IF Z1="^^"
SET FLAGE=1
+7 IF '$GET(FLAGE)
WRITE @IOF
+8 IF FLAGQ!($DATA(FLAGE))
QUIT
+9 IF $LENGTH(HD)
DO @HD
+10 QUIT
PAUSE ;
+1 ;
+2 QUIT
INIT7 ;
+1 ;I FLAGP,IO=IO(0),IOSL>25,IOST["C-" D SCROLL Q:FLAGQ
+2 ;W:IO'=IO(0) "Printing.."
IF FLAGP
USE IO
+3 DO HDR
QUIT
EX ;
+1 KILL FLAGPT,^UTILITY($JOB,"GROUP")
+2 QUIT
SCROLL ;Adjust scroll rate
+1 WRITE !!?8,"SCROLLING: [N]ormal [S]mooth . . . . ","Select: N//"
+2 READ SCROLL:DTIME
IF '$TEST
SET SCROLL="^"
SET SCROLL=$EXTRACT(SCROLL)
IF SCROLL="^"
SET FLAGQ=1
QUIT
+3 IF SCROLL="?"
WRITE !?8,"Since you're printing to your CRT and you've asked for a page",!?8,"length greater than 25, you may now adjust the scroll rate.",!?8,"For DEC VT-100 compatible devices only."
GOTO SCROLL
+4 IF SCROLL=""
SET SCROLL="N"
IF "S,s"'[SCROLL
QUIT
SET FLAGS=1
WRITE *27,"[?4h"
+5 QUIT
