- 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
