BHSUTL ;IHS/CIA/MGH - Health Summary Utilities ;09-Mar-2016 09:58;du
;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,7,8,9,13**;March 17, 2006;Build 6
;===================================================================
;Taken from APCHSUTL
; IHS/TUCSON/LAB - UTILITIES FOR APCHS -- SUMMARY PRODUCTION COMPONENTS
;;2.0;IHS RPMS/PCC Health Summary;**3,8**;JUN 24, 1997
;IHS health summary utilities to use in VA health summaries
;Updated in patch2 for CPT codes
;Updated in patch3 for CSV
;Patch 8 for snomed problem list
;Patch 9 for ICD-10
GETICDDX ;ENTRY POINT
;IHS/MSC/MGH Code set versioning changes entered
;S Y=$P(^ICD9(BHSICD,0),U,1)
;Patch 12 changes
I $$AICD^BHSUTL S Y=$$ICDDX^ICDEX(BHSICD,"","","I")
E S Y=$$ICDDX^ICDCODE(BHSICD) ;cmi/anch/maw 8/27/2007 code set version
;Patch 13 changes
N APCHSDSC
;I $$AICD^BHSUTL B S APCHSDSC=$$ICDD^ICDEX($P(Y,U,1),.APCHSDSC,$G(BHSCVD))
;E B S APCHSDSC=$$ICDD^ICDCODE($P(Y,U,2),.APCHSDSC)
S APCHSDSC=$P(Y,U,4)
S:GMPXICDF="L"!(GMPXICDF="Long text") BHSICD=$P(Y,U,2)_"-"_$S($D(APCHSDSC):$G(APCHSDSC),1:"<DESCRIPTION field missing>") ;cmi/anch/maw 8/27/20
S:GMPXICDF="S"!(GMPXICDF="Short text") BHSICD=$P(Y,U,2)_"-"_$S($D(APCHSDSC):$G(APCHSDSC),1:"<DIAGNOSIS field missing>") ;cmi/anch/maw 8/27/2007 code
S:GMPXICDF="C"!(GMPXICDF="Code only") BHSICD=$P(Y,U,2)
S:GMPXICDF="T"!(GMPXICDF="Text only") BHSICD=$P(Y,U,4)
S:GMPXICDF="N"!(GMPXICDF="None")!(GMPXICDF="") BHSICD=""
Q
GETPLICD ;EP
;IHS/MSC/MGH SNOMED changes
I $$AICD^BHSUTL S Y=$$ICDDX^ICDEX(BHSICD,"","","I")
E S Y=$$ICDDX^ICDCODE(BHSICD) ;cmi/anch/maw 8
S BHSICD=$P(Y,U,2)
Q
GETICDOP ;ENTRY POINT
;Patch 2 Code set versioning changed
;S Y=$P(^ICD0(BHSICD,0),U,1)
N BHSXY
I $$AICD^BHSUTL S BHSXY=$$ICDOP^ICDEX(BHSICD,"","","I")
E S BHSXY=$$ICDOP^ICDCODE(BHSICD)
I $P(BHSXY,U)="-1" S BHSXY=BHSICD_U_$P($G(^ICD0(BHSICD,0)),U,1)_U_U_$$VSTP^AUPNVUTL(BHSICD,$G(BHSCVD))
I $$AICD^BHSUTL S BHSDSC=$$ICDD^ICDEX($P(BHSXY,U,2),.BHSDSC,$G(BHSCVD))
E S BHSDSC=$$ICDD^ICDCODE($P(BHSXY,U,2),.BHSDSC,$G(BHSCSVD))
S:GMPXICDF="L" BHSICD=$P(BHSXY,U,2)_"-"_$S($D(BHSDSC(1)):$G(BHSDSC(1)),1:"<DESCRIPTION field missing>")
S:GMPXICDF="S" BHSICD=$P(BHSXY,U,2)_"-"_$S($P(BHSXY,U,5)]"":$P(BHSXY,U,5),1:"<DIAGNOSIS field missing>")
S:GMPXICDF="C" BHSICD=$P(BHSXY,U,2)
Q
GETCPT ;ENTRY POINT PATCH 2
;Patch 2Code set versioning changes
;S Y=$P(^ICPT(BHSICD,0),U,1)
S Y=$$CPT^ICPTCOD(BHSICD)
S:GMPXICDF="L" BHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
S:GMPXICDF="S" BHSICD=$P(Y,U,2)_"-"_$S($P(Y,U,3)]"":$P(Y,U,3),1:"<DESCRIPTION field missing>")
S:GMPXICDF="C" BHSICD=$P(Y,U,2)
Q
PRTICD ;ENTRY POINT
;I GMPXNARR="N" S:BHSNRQ="" BHSNRQ="<no narrative provided>" S BHSICD=""
S BHSTXT=BHSICD
;I GMPXNARR="Y" S BHSTXT=BHSTXT_" "_BHSNRQ
S:'$D(BHSNTE) BHSNTE=""
I BHSNTE]"" S BHSNTE=" "_BHSNTE
D PRTTXT
Q
;
PRTICDE ;ENTRY POINT
I BHSICF="N" S BHSICD=""
S:'$D(BHSNTE) BHSNTE=""
I BHSNTE]"" S BHSNTE=" "_BHSNTE
D PRTTXT
Q ;
PRTTXT ;PEP - PUBLISHED ENTRY POINT
; GENERALIZED TEXT PRINTER
N BHSQ
S:'$D(BHSNTE) BHSNTE=""
S BHSDLT=1,BHSILN=IOM-BHSICL-1
F BHSQ=0:0 D PRTTXT1 Q:BHSTXT="" D PRTTXT2
K BHSNTE
K BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
Q
PRTTXT1 ;
I GMPXNARR'="N" D
.S:BHSNRQ]""&(($L(BHSNRQ)+$L(BHSTXT)+2)<255) BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ,BHSNRQ=""
.S:BHSNTE]""&(BHSNRQ="")&(($L(BHSNTE)+$L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
I GMPXNARR="N" D
.S:($L(BHSTXT)+2)<255 BHSTXT=$S(BHSTXT]"":BHSTXT_"; ",1:""),BHSNRQ=""
.S:BHSNTE]""&(($L(BHSTXT)+2)<255) BHSTXT=BHSTXT_BHSNTE,BHSNTE=""
Q
PRTTXT2 D GETFRAG D CKP^GMTSUP Q:$D(GMTSQIT) W ?BHSICL W BHSF,!
S BHSICL=BHSICL+BHSDLT,BHSILN=BHSILN-BHSDLT,BHSDLT=0
Q
GETFRAG I $L(BHSTXT)<BHSILN S BHSF=BHSTXT,BHSTXT="" Q
F BHSC=BHSILN:-1:0 Q:$E(BHSTXT,BHSC)=" "
S:BHSC=0 BHSC=BHSILN
S BHSF=$E(BHSTXT,1,BHSC-1),BHSTXT=$E(BHSTXT,BHSC+1,255)
Q
;
GETNARR ;ENTRY POINT
;I BHSNRQ]"",GMPXNARR="Y" S BHSNRQ=$S($D(^AUTNPOV(BHSNRQ)):$P(^AUTNPOV(BHSNRQ,0),U,1),1:"***** "_BHSNRQ_" *****")
N SNONAR
S SNONAR=""
I BHSNRQ]"",GMPXNARR="Y" D
.S SNONAR=$$SNOMED^AUPNVUTL(BHSNRQ)
.S BHSNRQ=$S(SNONAR'="":SNONAR,1:"***** "_BHSNRQ_" *****")
E S BHSNRQ=""
Q
;
GETSITEV ;ENTRY POINT
S BHSP=^AUPNVSIT(BHSVDF,0),BHSVSC=$P(BHSP,U,7),BHSITE=$P(BHSP,U,6)
GETSITE ;ENTRY POINT
S:BHSITE="" BHSITE="null"
S BHSP=$G(^AUTTLOC(BHSITE,0))
S:'$D(BHSVDF) BHSVDF=-1
S BHSNFL=$P(BHSP,U,1) S:BHSNFL="" BHSNFL="null" S BHSNFL=$S($D(^DIC(4,BHSNFL,0)):$P(^(0),U,1),$P($G(^AUPNVSIT(BHSVDF,21)),U)]"":$P(^(21),U),1:"<"_BHSITE_">") ;IHS/CMI/LAB - fixed this line
S BHSNSH=$P(BHSP,U,2) S:$P($G(^AUPNVSIT(BHSVDF,21)),U)]"" BHSNSH=$E($P(^(21),U),1,12) I BHSNSH="" S BHSNSH="<"_BHSITE_">" ;IHS/CMI/LAB - fixed this line to replace the one above
K:BHSVDF=-1 BHSVDF
S BHSNAB=$J($P(BHSP,U,7),4) I BHSNAB="" S BHSNAB="<"_BHSITE_">"
Q
;
; THE FOLLOWING CODE SEGMENTS ARE CALLED FROM 'ROUTINE"-TYPE
; MENU OPTIONS TO DISPLAY ITEMS IN A FILE
;
LM ;ENTRY POINT - FOR BHSLST MEASUREMENT PANEL TYPES
S BHSLST="^APCHSMPN(" G DSPLST
;
LI ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEET ITEMS
S BHSLST="^APCHSFLI(" G DSPLST
;
LF ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEETS
S BHSLST="^APCHSFLC(" G DSPLST
;
DSPLST ; COMMON CODE FOR BUILD HLTH SUM & HLTH SUM MNX LISTS
K DIR
I '$D(@(BHSLST_"""B"")")) W !,"NO ",$P(@(BHSLST_"0)"),U),"S DEFINED.",! Q
W @IOF,!!,"Existing ",$P(@(BHSLST_"0)"),U),"S:",! S BHSCNT=""
CONT F S BHSCNT=$O(@(BHSLST_"""B"",BHSCNT)")) Q:BHSCNT="" W !,?5,BHSCNT I (IOSL-3)<$Y S DIR(0)="E" D ^DIR W @IOF G:1'[Y QUIT
K DIR S DIR(0)="E" D ^DIR W !
Q
;
GENFG ;generate filegrams for export
MEASPAN ;
N DIFG,DIFGT,DILC,DIFGER
W !,"REMEMBER TO KILL APCHTMP BEFORE DOING THIS",!
S APCHT="MEASPAN",APCHC=0 F APCHX="ADULT STD","ADULT STD METRIC","PEDIATRIC STD","PEDIATRIC STD METRIC" S DIFGT=$O(^DIPT("B","APCH MP TYPE",0)) D
.I 'DIFGT W !,"measurement panel fg missing" Q
.S DIFG("FE")=$O(^BHS(90470,"B",APCHX,0))
.I 'DIFG("FE") W !,"panel ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
FLOW ;
G TYPE
S APCHT="FLOW",APCHC=0 F APCHX="DIABETIC FLOWSHEET" S DIFGT=$O(^DIPT("B","APCH FS TYPE",0)) D
.I 'DIFGT W !,"flowsheet fg missing" Q
.S DIFG("FE")=$O(^APCHSFLC("B",APCHX,0))
.I 'DIFG("FE") W !,"flowsheet ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
TYPE ;
S APCHT="TYPE",APCHC=0 F APCHX="ADULT REGULAR","CHR","DENTAL","DIABETES STANDARD","IMMUNIZATION","MENTAL HEALTH/SOCIAL SERVICES","PEDIATRIC","PATIENT MERGE (COMPLETE)","PROBLEM LIST" S DIFGT=$O(^DIPT("B","APCH HS TYPE",0)) D
.I 'DIFGT W !,"health summary type fg missing" Q
.S DIFG("FE")=$O(^GMT(142,"B",APCHX,0))
.I 'DIFG("FE") W !,"type ",APCHX," missing.",! Q
.S APCHC=APCHC+1
.D GEN1
.Q
K APCHC,APCHT W !,"all done"
Q
GEN1 ;
S DIFG("FUNC")="A"
S DIFG("FGR")="^APCHTMP("""_APCHT_""",APCHC,"
S DILC=0
D EN^DIFGG
I $D(DIFGER) W !,"error on ",APCHT," item ",APCHX,!
Q
QUIT K DIR,X,Y,BHSLST,BHSCNT
Q
AICD() ;EP
Q $S($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
BHSUTL ;IHS/CIA/MGH - Health Summary Utilities ;09-Mar-2016 09:58;du
+1 ;;1.0;HEALTH SUMMARY COMPONENTS;**1,2,3,4,7,8,9,13**;March 17, 2006;Build 6
+2 ;===================================================================
+3 ;Taken from APCHSUTL
+4 ; IHS/TUCSON/LAB - UTILITIES FOR APCHS -- SUMMARY PRODUCTION COMPONENTS
+5 ;;2.0;IHS RPMS/PCC Health Summary;**3,8**;JUN 24, 1997
+6 ;IHS health summary utilities to use in VA health summaries
+7 ;Updated in patch2 for CPT codes
+8 ;Updated in patch3 for CSV
+9 ;Patch 8 for snomed problem list
+10 ;Patch 9 for ICD-10
GETICDDX ;ENTRY POINT
+1 ;IHS/MSC/MGH Code set versioning changes entered
+2 ;S Y=$P(^ICD9(BHSICD,0),U,1)
+3 ;Patch 12 changes
+4 IF $$AICD^BHSUTL
SET Y=$$ICDDX^ICDEX(BHSICD,"","","I")
+5 ;cmi/anch/maw 8/27/2007 code set version
IF '$TEST
SET Y=$$ICDDX^ICDCODE(BHSICD)
+6 ;Patch 13 changes
+7 NEW APCHSDSC
+8 ;I $$AICD^BHSUTL B S APCHSDSC=$$ICDD^ICDEX($P(Y,U,1),.APCHSDSC,$G(BHSCVD))
+9 ;E B S APCHSDSC=$$ICDD^ICDCODE($P(Y,U,2),.APCHSDSC)
+10 SET APCHSDSC=$PIECE(Y,U,4)
+11 ;cmi/anch/maw 8/27/20
IF GMPXICDF="L"!(GMPXICDF="Long text")
SET BHSICD=$PIECE(Y,U,2)_"-"_$SELECT($DATA(APCHSDSC):$GET(APCHSDSC),1:"<DESCRIPTION field missing>")
+12 ;cmi/anch/maw 8/27/2007 code
IF GMPXICDF="S"!(GMPXICDF="Short text")
SET BHSICD=$PIECE(Y,U,2)_"-"_$SELECT($DATA(APCHSDSC):$GET(APCHSDSC),1:"<DIAGNOSIS field missing>")
+13 IF GMPXICDF="C"!(GMPXICDF="Code only")
SET BHSICD=$PIECE(Y,U,2)
+14 IF GMPXICDF="T"!(GMPXICDF="Text only")
SET BHSICD=$PIECE(Y,U,4)
+15 IF GMPXICDF="N"!(GMPXICDF="None")!(GMPXICDF="")
SET BHSICD=""
+16 QUIT
GETPLICD ;EP
+1 ;IHS/MSC/MGH SNOMED changes
+2 IF $$AICD^BHSUTL
SET Y=$$ICDDX^ICDEX(BHSICD,"","","I")
+3 ;cmi/anch/maw 8
IF '$TEST
SET Y=$$ICDDX^ICDCODE(BHSICD)
+4 SET BHSICD=$PIECE(Y,U,2)
+5 QUIT
GETICDOP ;ENTRY POINT
+1 ;Patch 2 Code set versioning changed
+2 ;S Y=$P(^ICD0(BHSICD,0),U,1)
+3 NEW BHSXY
+4 IF $$AICD^BHSUTL
SET BHSXY=$$ICDOP^ICDEX(BHSICD,"","","I")
+5 IF '$TEST
SET BHSXY=$$ICDOP^ICDCODE(BHSICD)
+6 IF $PIECE(BHSXY,U)="-1"
SET BHSXY=BHSICD_U_$PIECE($GET(^ICD0(BHSICD,0)),U,1)_U_U_$$VSTP^AUPNVUTL(BHSICD,$GET(BHSCVD))
+7 IF $$AICD^BHSUTL
SET BHSDSC=$$ICDD^ICDEX($PIECE(BHSXY,U,2),.BHSDSC,$GET(BHSCVD))
+8 IF '$TEST
SET BHSDSC=$$ICDD^ICDCODE($PIECE(BHSXY,U,2),.BHSDSC,$GET(BHSCSVD))
+9 IF GMPXICDF="L"
SET BHSICD=$PIECE(BHSXY,U,2)_"-"_$SELECT($DATA(BHSDSC(1)):$GET(BHSDSC(1)),1:"<DESCRIPTION field missing>")
+10 IF GMPXICDF="S"
SET BHSICD=$PIECE(BHSXY,U,2)_"-"_$SELECT($PIECE(BHSXY,U,5)]"":$PIECE(BHSXY,U,5),1:"<DIAGNOSIS field missing>")
+11 IF GMPXICDF="C"
SET BHSICD=$PIECE(BHSXY,U,2)
+12 QUIT
GETCPT ;ENTRY POINT PATCH 2
+1 ;Patch 2Code set versioning changes
+2 ;S Y=$P(^ICPT(BHSICD,0),U,1)
+3 SET Y=$$CPT^ICPTCOD(BHSICD)
+4 IF GMPXICDF="L"
SET BHSICD=$PIECE(Y,U,2)_"-"_$SELECT($PIECE(Y,U,3)]"":$PIECE(Y,U,3),1:"<DESCRIPTION field missing>")
+5 IF GMPXICDF="S"
SET BHSICD=$PIECE(Y,U,2)_"-"_$SELECT($PIECE(Y,U,3)]"":$PIECE(Y,U,3),1:"<DESCRIPTION field missing>")
+6 IF GMPXICDF="C"
SET BHSICD=$PIECE(Y,U,2)
+7 QUIT
PRTICD ;ENTRY POINT
+1 ;I GMPXNARR="N" S:BHSNRQ="" BHSNRQ="<no narrative provided>" S BHSICD=""
+2 SET BHSTXT=BHSICD
+3 ;I GMPXNARR="Y" S BHSTXT=BHSTXT_" "_BHSNRQ
+4 IF '$DATA(BHSNTE)
SET BHSNTE=""
+5 IF BHSNTE]""
SET BHSNTE=" "_BHSNTE
+6 DO PRTTXT
+7 QUIT
+8 ;
PRTICDE ;ENTRY POINT
+1 IF BHSICF="N"
SET BHSICD=""
+2 IF '$DATA(BHSNTE)
SET BHSNTE=""
+3 IF BHSNTE]""
SET BHSNTE=" "_BHSNTE
+4 DO PRTTXT
+5 ;
QUIT
PRTTXT ;PEP - PUBLISHED ENTRY POINT
+1 ; GENERALIZED TEXT PRINTER
+2 NEW BHSQ
+3 IF '$DATA(BHSNTE)
SET BHSNTE=""
+4 SET BHSDLT=1
SET BHSILN=IOM-BHSICL-1
+5 FOR BHSQ=0:0
DO PRTTXT1
IF BHSTXT=""
QUIT
DO PRTTXT2
+6 KILL BHSNTE
+7 KILL BHSILN,BHSDLT,BHSF,BHSC,BHSTXT
+8 QUIT
PRTTXT1 ;
+1 IF GMPXNARR'="N"
Begin DoDot:1
+2 IF BHSNRQ]""&(($LENGTH(BHSNRQ)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT_"; ",1:"")_BHSNRQ
SET BHSNRQ=""
+3 IF BHSNTE]""&(BHSNRQ="")&(($LENGTH(BHSNTE)+$LENGTH(BHSTXT)+2)<255)
SET BHSTXT=BHSTXT_BHSNTE
SET BHSNTE=""
End DoDot:1
+4 IF GMPXNARR="N"
Begin DoDot:1
+5 IF ($LENGTH(BHSTXT)+2)<255
SET BHSTXT=$SELECT(BHSTXT]"":BHSTXT_"; ",1:"")
SET BHSNRQ=""
+6 IF BHSNTE]""&(($LENGTH(BHSTXT)+2)<255)
SET BHSTXT=BHSTXT_BHSNTE
SET BHSNTE=""
End DoDot:1
+7 QUIT
PRTTXT2 DO GETFRAG
DO CKP^GMTSUP
IF $DATA(GMTSQIT)
QUIT
WRITE ?BHSICL
WRITE BHSF,!
+1 SET BHSICL=BHSICL+BHSDLT
SET BHSILN=BHSILN-BHSDLT
SET BHSDLT=0
+2 QUIT
GETFRAG IF $LENGTH(BHSTXT)<BHSILN
SET BHSF=BHSTXT
SET BHSTXT=""
QUIT
+1 FOR BHSC=BHSILN:-1:0
IF $EXTRACT(BHSTXT,BHSC)=" "
QUIT
+2 IF BHSC=0
SET BHSC=BHSILN
+3 SET BHSF=$EXTRACT(BHSTXT,1,BHSC-1)
SET BHSTXT=$EXTRACT(BHSTXT,BHSC+1,255)
+4 QUIT
+5 ;
GETNARR ;ENTRY POINT
+1 ;I BHSNRQ]"",GMPXNARR="Y" S BHSNRQ=$S($D(^AUTNPOV(BHSNRQ)):$P(^AUTNPOV(BHSNRQ,0),U,1),1:"***** "_BHSNRQ_" *****")
+2 NEW SNONAR
+3 SET SNONAR=""
+4 IF BHSNRQ]""
IF GMPXNARR="Y"
Begin DoDot:1
+5 SET SNONAR=$$SNOMED^AUPNVUTL(BHSNRQ)
+6 SET BHSNRQ=$SELECT(SNONAR'="":SNONAR,1:"***** "_BHSNRQ_" *****")
End DoDot:1
+7 IF '$TEST
SET BHSNRQ=""
+8 QUIT
+9 ;
GETSITEV ;ENTRY POINT
+1 SET BHSP=^AUPNVSIT(BHSVDF,0)
SET BHSVSC=$PIECE(BHSP,U,7)
SET BHSITE=$PIECE(BHSP,U,6)
GETSITE ;ENTRY POINT
+1 IF BHSITE=""
SET BHSITE="null"
+2 SET BHSP=$GET(^AUTTLOC(BHSITE,0))
+3 IF '$DATA(BHSVDF)
SET BHSVDF=-1
+4 ;IHS/CMI/LAB - fixed this line
SET BHSNFL=$PIECE(BHSP,U,1)
IF BHSNFL=""
SET BHSNFL="null"
SET BHSNFL=$SELECT($DATA(^DIC(4,BHSNFL,0)):$PIECE(^(0),U,1),$PIECE($GET(^AUPNVSIT(BHSVDF,21)),U)]"":$PIECE(^(21),U),1:"<"_BHSITE_">")
+5 ;IHS/CMI/LAB - fixed this line to replace the one above
SET BHSNSH=$PIECE(BHSP,U,2)
IF $PIECE($GET(^AUPNVSIT(BHSVDF,21)),U)]""
SET BHSNSH=$EXTRACT($PIECE(^(21),U),1,12)
IF BHSNSH=""
SET BHSNSH="<"_BHSITE_">"
+6 IF BHSVDF=-1
KILL BHSVDF
+7 SET BHSNAB=$JUSTIFY($PIECE(BHSP,U,7),4)
IF BHSNAB=""
SET BHSNAB="<"_BHSITE_">"
+8 QUIT
+9 ;
+10 ; THE FOLLOWING CODE SEGMENTS ARE CALLED FROM 'ROUTINE"-TYPE
+11 ; MENU OPTIONS TO DISPLAY ITEMS IN A FILE
+12 ;
LM ;ENTRY POINT - FOR BHSLST MEASUREMENT PANEL TYPES
+1 SET BHSLST="^APCHSMPN("
GOTO DSPLST
+2 ;
LI ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEET ITEMS
+1 SET BHSLST="^APCHSFLI("
GOTO DSPLST
+2 ;
LF ;ENTRY POINT - FOR BHSLST HLTH SUM FLOWSHEETS
+1 SET BHSLST="^APCHSFLC("
GOTO DSPLST
+2 ;
DSPLST ; COMMON CODE FOR BUILD HLTH SUM & HLTH SUM MNX LISTS
+1 KILL DIR
+2 IF '$DATA(@(BHSLST_"""B"")"))
WRITE !,"NO ",$PIECE(@(BHSLST_"0)"),U),"S DEFINED.",!
QUIT
+3 WRITE @IOF,!!,"Existing ",$PIECE(@(BHSLST_"0)"),U),"S:",!
SET BHSCNT=""
CONT FOR
SET BHSCNT=$ORDER(@(BHSLST_"""B"",BHSCNT)"))
IF BHSCNT=""
QUIT
WRITE !,?5,BHSCNT
IF (IOSL-3)<$Y
SET DIR(0)="E"
DO ^DIR
WRITE @IOF
IF 1'[Y
GOTO QUIT
+1 KILL DIR
SET DIR(0)="E"
DO ^DIR
WRITE !
+2 QUIT
+3 ;
GENFG ;generate filegrams for export
MEASPAN ;
+1 NEW DIFG,DIFGT,DILC,DIFGER
+2 WRITE !,"REMEMBER TO KILL APCHTMP BEFORE DOING THIS",!
+3 SET APCHT="MEASPAN"
SET APCHC=0
FOR APCHX="ADULT STD","ADULT STD METRIC","PEDIATRIC STD","PEDIATRIC STD METRIC"
SET DIFGT=$ORDER(^DIPT("B","APCH MP TYPE",0))
Begin DoDot:1
+4 IF 'DIFGT
WRITE !,"measurement panel fg missing"
QUIT
+5 SET DIFG("FE")=$ORDER(^BHS(90470,"B",APCHX,0))
+6 IF 'DIFG("FE")
WRITE !,"panel ",APCHX," missing.",!
QUIT
+7 SET APCHC=APCHC+1
+8 DO GEN1
+9 QUIT
End DoDot:1
FLOW ;
+1 GOTO TYPE
+2 SET APCHT="FLOW"
SET APCHC=0
FOR APCHX="DIABETIC FLOWSHEET"
SET DIFGT=$ORDER(^DIPT("B","APCH FS TYPE",0))
Begin DoDot:1
+3 IF 'DIFGT
WRITE !,"flowsheet fg missing"
QUIT
+4 SET DIFG("FE")=$ORDER(^APCHSFLC("B",APCHX,0))
+5 IF 'DIFG("FE")
WRITE !,"flowsheet ",APCHX," missing.",!
QUIT
+6 SET APCHC=APCHC+1
+7 DO GEN1
+8 QUIT
End DoDot:1
TYPE ;
+1 SET APCHT="TYPE"
SET APCHC=0
FOR APCHX="ADULT REGULAR","CHR","DENTAL","DIABETES STANDARD","IMMUNIZATION","MENTAL HEALTH/SOCIAL SERVICES","PEDIATRIC","PATIENT MERGE (COMPLETE)","PROBLEM LIST"
SET DIFGT=$ORDER(^DIPT("B","APCH HS TYPE",0))
Begin DoDot:1
+2 IF 'DIFGT
WRITE !,"health summary type fg missing"
QUIT
+3 SET DIFG("FE")=$ORDER(^GMT(142,"B",APCHX,0))
+4 IF 'DIFG("FE")
WRITE !,"type ",APCHX," missing.",!
QUIT
+5 SET APCHC=APCHC+1
+6 DO GEN1
+7 QUIT
End DoDot:1
+8 KILL APCHC,APCHT
WRITE !,"all done"
+9 QUIT
GEN1 ;
+1 SET DIFG("FUNC")="A"
+2 SET DIFG("FGR")="^APCHTMP("""_APCHT_""",APCHC,"
+3 SET DILC=0
+4 DO EN^DIFGG
+5 IF $DATA(DIFGER)
WRITE !,"error on ",APCHT," item ",APCHX,!
+6 QUIT
QUIT KILL DIR,X,Y,BHSLST,BHSCNT
+1 QUIT
AICD() ;EP
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")<"4.0":0,1:1)
