BGPMUUTL ; IHS/MSC/MMT - Meaningful Use Reporting Utilities;02-Mar-2011 11:55;DU
;;14.1;IHS CLINICAL REPORTING;**1**;MAY 29, 2014;Build 2
;
VER() ;EP
Q "CRS 2014, Version 14.1 Patch 1"
JRNL ;EP
N %DT,U,ZTQUEUED
S %=$$NOJOURN^ZIBGCHAR("BGPGPDCT"),%=$$NOJOURN^ZIBGCHAR("BGPGPDPT"),%=$$NOJOURN^ZIBGCHAR("BGPGPDBT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDCT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDPT"),%=$$NOJOURN^ZIBGCHAR("BGPHEDBT")
S %=$$NOJOURN^ZIBGCHAR("BGPDATA"),%=$$NOJOURN^ZIBGCHAR("BGPGUI")
;S %=$$NOJOURN^ZIBGCHAR("BGPELDCT"),%=$$NOJOURN^ZIBGCHAR("BGPELDPT"),%=$$NOJOURN^ZIBGCHAR("BGPELDBT")
;S %=$$NOJOURN^ZIBGCHAR("BGPEOCT"),%=$$NOJOURN^ZIBGCHAR("BGPEOPT"),%=$$NOJOURN^ZIBGCHAR("BGPEOBT")
S %=$$NOJOURN^ZIBGCHAR("BGPXPT")
Q
PTLSORT(RETARR,INARR) ;EP - SORTS AN ARRAY OF PATIENTS TO DESIRED ORDER
N PT,DFN,DATA,COMM,SEX,AGE,HRN,TMPARR,OCNT
K RETARR,TMPARR
S PT=""
;Move all patients into an array subscripted by sort criteria
F S PT=$O(@INARR@(PT)) Q:PT="" D
.S DATA=@INARR@(PT),DFN=$P(DATA,U,1)
.S COMM=$$GET1^DIQ(9000001,DFN,1118) S:COMM="" COMM=" "
.S SEX=$P(^DPT(DFN,0),U,2) S:SEX="" SEX=" "
.S AGE=$$AGE^AUPNPAT(DFN,BGPED) S:AGE="" AGE=" "
.S HRN=$$HRN^AUPNPAT(DFN,DUZ(2)) S:HRN="" HRN=" "
.S TMPARR(COMM,SEX,AGE,HRN,PT)=DFN
S OCNT=0
S COMM="" F S COMM=$O(TMPARR(COMM)) Q:COMM="" D
.S SEX="" F S SEX=$O(TMPARR(COMM,SEX)) Q:SEX="" D
..S AGE="" F S AGE=$O(TMPARR(COMM,SEX,AGE)) Q:AGE="" D
...S HRN="" F S HRN=$O(TMPARR(COMM,SEX,AGE,HRN)) Q:HRN="" D
....S PT="" F S PT=$O(TMPARR(COMM,SEX,AGE,HRN,PT)) Q:PT="" D
.....;S PT=TMPARR(COMM,SEX,AGE,HRN)
.....S OCNT=OCNT+1
.....S RETARR(OCNT)=@INARR@(PT)
Q
DATE(D) ;EP
I D="" Q ""
Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
;
XTMP(N,D) ;EP
Q:$G(N)=""
S ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$G(D)
Q
MAPLOAD ;EP Enter a fle name to map to NDC codes
N BGPPATH,BGPFN,Y,X,NDC,RXNORM
S DIR(0)="F^1:40",DIR("A")="Enter a filename for the delimited input (no more than 40 characters)" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BGPPATH=Y
S BGPFN=$P(BGPPATH,"\",-1),$P(BGPPATH,"\",-1)=""
S Y=$$OPEN^%ZISH(BGPPATH,BGPFN,"R")
I Y=1 W:'$D(ZTQUEUED) !!,"Cannot open host file." Q
F I=1:1 U IO R X:DTIME S X=$$STRIP(X) Q:X="" S RXNORM=$P(X,"|",2),NDC=$P(X,"|",1),^BGPMUTMP("NDC MAP","X",RXNORM,NDC)="" Q:$$STATUS^%ZISH=-1
D ^%ZISC
W !!,"All done reading file",!
Q
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
NEW I
F I=1:1:$L(Z) I (32>$A($E(Z,I))) S Z=$E(Z,1,I-1)_""_$E(Z,I+1,999)
Q Z
XWALK ;EP
N BGPRXN,BGPRXNLT,BGPFND,BGPNDC,BGPNDCLT
S DIR(0)="F",DIR("A")="Enter a comma delimited list of RxNorm codes" KILL DA D ^DIR KILL DIR
I $D(DIRUT) Q
S BGPRXNLT=Y
S BGPRXNLT=$TR(BGPRXNLT," ")
S BGPNDCLT=""
F I=1:1:$L(BGPRXNLT,",") D
.S BGPRXN=$P(BGPRXNLT,",",I),BGPNDC="",BGPFND=0
.F S BGPNDC=$O(^BGPMUTMP("NDC MAP","X",BGPRXN,BGPNDC)) Q:BGPNDC="" D
..S BGPNDCLT=BGPNDCLT_","_BGPNDC
..S BGPFND=1
.W:'BGPFND !,"RxNorm code "_BGPRXN_" not found!"
S BGPNDCLT=$E(BGPNDCLT,2,*)
W !!,"Mapped NDC Codes:",!,BGPNDCLT
Q
BGPMUUTL ; IHS/MSC/MMT - Meaningful Use Reporting Utilities;02-Mar-2011 11:55;DU
+1 ;;14.1;IHS CLINICAL REPORTING;**1**;MAY 29, 2014;Build 2
+2 ;
VER() ;EP
+1 QUIT "CRS 2014, Version 14.1 Patch 1"
JRNL ;EP
+1 NEW %DT,U,ZTQUEUED
+2 SET %=$$NOJOURN^ZIBGCHAR("BGPGPDCT")
SET %=$$NOJOURN^ZIBGCHAR("BGPGPDPT")
SET %=$$NOJOURN^ZIBGCHAR("BGPGPDBT")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDCT")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDPT")
SET %=$$NOJOURN^ZIBGCHAR("BGPHEDBT")
+3 SET %=$$NOJOURN^ZIBGCHAR("BGPDATA")
SET %=$$NOJOURN^ZIBGCHAR("BGPGUI")
+4 ;S %=$$NOJOURN^ZIBGCHAR("BGPELDCT"),%=$$NOJOURN^ZIBGCHAR("BGPELDPT"),%=$$NOJOURN^ZIBGCHAR("BGPELDBT")
+5 ;S %=$$NOJOURN^ZIBGCHAR("BGPEOCT"),%=$$NOJOURN^ZIBGCHAR("BGPEOPT"),%=$$NOJOURN^ZIBGCHAR("BGPEOBT")
+6 SET %=$$NOJOURN^ZIBGCHAR("BGPXPT")
+7 QUIT
PTLSORT(RETARR,INARR) ;EP - SORTS AN ARRAY OF PATIENTS TO DESIRED ORDER
+1 NEW PT,DFN,DATA,COMM,SEX,AGE,HRN,TMPARR,OCNT
+2 KILL RETARR,TMPARR
+3 SET PT=""
+4 ;Move all patients into an array subscripted by sort criteria
+5 FOR
SET PT=$ORDER(@INARR@(PT))
IF PT=""
QUIT
Begin DoDot:1
+6 SET DATA=@INARR@(PT)
SET DFN=$PIECE(DATA,U,1)
+7 SET COMM=$$GET1^DIQ(9000001,DFN,1118)
IF COMM=""
SET COMM=" "
+8 SET SEX=$PIECE(^DPT(DFN,0),U,2)
IF SEX=""
SET SEX=" "
+9 SET AGE=$$AGE^AUPNPAT(DFN,BGPED)
IF AGE=""
SET AGE=" "
+10 SET HRN=$$HRN^AUPNPAT(DFN,DUZ(2))
IF HRN=""
SET HRN=" "
+11 SET TMPARR(COMM,SEX,AGE,HRN,PT)=DFN
End DoDot:1
+12 SET OCNT=0
+13 SET COMM=""
FOR
SET COMM=$ORDER(TMPARR(COMM))
IF COMM=""
QUIT
Begin DoDot:1
+14 SET SEX=""
FOR
SET SEX=$ORDER(TMPARR(COMM,SEX))
IF SEX=""
QUIT
Begin DoDot:2
+15 SET AGE=""
FOR
SET AGE=$ORDER(TMPARR(COMM,SEX,AGE))
IF AGE=""
QUIT
Begin DoDot:3
+16 SET HRN=""
FOR
SET HRN=$ORDER(TMPARR(COMM,SEX,AGE,HRN))
IF HRN=""
QUIT
Begin DoDot:4
+17 SET PT=""
FOR
SET PT=$ORDER(TMPARR(COMM,SEX,AGE,HRN,PT))
IF PT=""
QUIT
Begin DoDot:5
+18 ;S PT=TMPARR(COMM,SEX,AGE,HRN)
+19 SET OCNT=OCNT+1
+20 SET RETARR(OCNT)=@INARR@(PT)
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
DATE(D) ;EP
+1 IF D=""
QUIT ""
+2 QUIT $EXTRACT(D,4,5)_"/"_$EXTRACT(D,6,7)_"/"_$EXTRACT(D,2,3)
+3 ;
XTMP(N,D) ;EP
+1 IF $GET(N)=""
QUIT
+2 SET ^XTMP(N,0)=$$FMADD^XLFDT(DT,14)_"^"_DT_"^"_$GET(D)
+3 QUIT
MAPLOAD ;EP Enter a fle name to map to NDC codes
+1 NEW BGPPATH,BGPFN,Y,X,NDC,RXNORM
+2 SET DIR(0)="F^1:40"
SET DIR("A")="Enter a filename for the delimited input (no more than 40 characters)"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET BGPPATH=Y
+5 SET BGPFN=$PIECE(BGPPATH,"\",-1)
SET $PIECE(BGPPATH,"\",-1)=""
+6 SET Y=$$OPEN^%ZISH(BGPPATH,BGPFN,"R")
+7 IF Y=1
IF '$DATA(ZTQUEUED)
WRITE !!,"Cannot open host file."
QUIT
+8 FOR I=1:1
USE IO
READ X:DTIME
SET X=$$STRIP(X)
IF X=""
QUIT
SET RXNORM=$PIECE(X,"|",2)
SET NDC=$PIECE(X,"|",1)
SET ^BGPMUTMP("NDC MAP","X",RXNORM,NDC)=""
IF $$STATUS^%ZISH=-1
QUIT
+9 DO ^%ZISC
+10 WRITE !!,"All done reading file",!
+11 QUIT
STRIP(Z) ;REMOVE CONTROLL CHARACTERS
+1 NEW I
+2 FOR I=1:1:$LENGTH(Z)
IF (32>$ASCII($EXTRACT(Z,I)))
SET Z=$EXTRACT(Z,1,I-1)_""_$EXTRACT(Z,I+1,999)
+3 QUIT Z
XWALK ;EP
+1 NEW BGPRXN,BGPRXNLT,BGPFND,BGPNDC,BGPNDCLT
+2 SET DIR(0)="F"
SET DIR("A")="Enter a comma delimited list of RxNorm codes"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
QUIT
+4 SET BGPRXNLT=Y
+5 SET BGPRXNLT=$TRANSLATE(BGPRXNLT," ")
+6 SET BGPNDCLT=""
+7 FOR I=1:1:$LENGTH(BGPRXNLT,",")
Begin DoDot:1
+8 SET BGPRXN=$PIECE(BGPRXNLT,",",I)
SET BGPNDC=""
SET BGPFND=0
+9 FOR
SET BGPNDC=$ORDER(^BGPMUTMP("NDC MAP","X",BGPRXN,BGPNDC))
IF BGPNDC=""
QUIT
Begin DoDot:2
+10 SET BGPNDCLT=BGPNDCLT_","_BGPNDC
+11 SET BGPFND=1
End DoDot:2
+12 IF 'BGPFND
WRITE !,"RxNorm code "_BGPRXN_" not found!"
End DoDot:1
+13 SET BGPNDCLT=$EXTRACT(BGPNDCLT,2,*)
+14 WRITE !!,"Mapped NDC Codes:",!,BGPNDCLT
+15 QUIT
