- GMTSPLST ; SLC/JER,KER,TC - Problem List ;07/02/13 09:56
- ;;2.7;Health Summary;**28,35,52,86,101**;Oct 20, 1995;Build 12
- ;
- ; External References
- ; DBIA 10011 ^DIWP
- ; DBIA 1183 GETLIST^GMPLHS
- ; DBIA 1573 $$DSMONE^LEXU
- ;
- ; Variable NEWed/KILLed Elsewhere
- ; DFN, GMPXICDF, GMPXNARR, GMTSNPG, GMTSQIT
- ;
- ACTIVE ; Get Active Problems
- N STATUS S STATUS="A" D MAIN Q
- INACT ; Get Inactive Problems
- N STATUS S STATUS="I" D MAIN Q
- ALL ; Get All Problems (Active and Inactive)
- N STATUS S STATUS="ALL" D MAIN Q
- MAIN ; Driver
- D GETLIST^GMPLHS(DFN,STATUS) Q:'$D(^TMP("GMPLHS",$J)) D SUBHDR D WRT K ^TMP("GMPLHS",$J) Q
- ;
- WRT ; Writes Problem List Component,X
- ;
- ; ^TMP("GMPLHS",$J,#,0)=
- ; Piece 1: Diagnosis
- ; 2: Date Last Modified
- ; 3: Site
- ; 4: Date Entered
- ; 5: Status
- ; 6: Date of Onset
- ; 7: Responsible Provider
- ; 8: Service
- ; 9: Service Abbreviation
- ; 10: Date Resolved
- ; 11: Clinic
- ; 12: Date Recorded
- ; 13: Problem - Lexicon Term
- ; 14: Exposure Combined String
- ; 15: SNOMED-CT Concept Code
- ; 16: SNOMED-CT Preferred Text
- ; 17: ICD-9-CM Code
- ; 18: ICD-9-CM Description
- ; 19: VHAT Concept Code
- ; 20: VHAT Preferred Text
- ; 21: Date of Interest
- ; 22: Coding System (of Primary diagnosis)
- ;
- ; ^TMP("GMPLHS",$J,#,#,"ICD9") Other multiple mapped ICD-9-CM codes
- ; ^TMP("GMPLHS",$J,#,"L") Lexicon Term
- ; ^TMP("GMPLHS",$J,#,"N") Provider Narrative
- ; ^TMP("GMPLHS",$J,#,"C",LOC,#,0)) Comments
- ;
- N GMREC,GMTSICL,GMTAB,LINE1,DIWL,GMTSTXTF
- S GMTSICL=32,DIWL=0,GMTAB=0,GMREC=0,GMTSTXTF=0
- F S GMREC=$O(^TMP("GMPLHS",$J,GMREC)) Q:GMREC'>0 D Q:$D(GMTSQIT)
- . N GMNODE,GMDIAG,GMDIAC,GMDIAT,GMDIAS,LASTMDT,STAT,ONSETDT,PROV,SERV,GMSCT,GMVHAT,GMTSDINT,GMTSCSYS
- . N RESDT,NARR,GMICD,GMDSM,GMDSMS,CODE,LEXI,LEX,PLIFN,ADDINFO,EXP,GMTSX,X,GMDIAC,GMDIAT,GMTSILBL
- . S (GMDIAC,GMDIAT)=""
- . S GMNODE=$G(^TMP("GMPLHS",$J,GMREC,0))
- . Q:GMNODE']""
- . S GMDIAG=$P(GMNODE,U),LASTMDT=$P(GMNODE,U,2),STAT=$P(GMNODE,U,5)
- . S GMTSDINT=$P(GMNODE,U,21),GMTSCSYS=$P(GMNODE,U,22),GMTSILBL=$S($G(GMTSCSYS)="ICD":"ICD-9-CM ",1:"ICD-10-CM ")
- . S X=LASTMDT D REGDT4^GMTSU S LASTMDT=X
- . S ONSETDT=$P(GMNODE,U,6),PROV=$P(GMNODE,U,7)
- . S RESDT=$P(GMNODE,U,10),GMICD="",GMSCT=$P(GMNODE,U,15),GMVHAT=$P(GMNODE,U,19)
- . S EXP=$P(GMNODE,U,14) S:$L(EXP) EXP=" ("_EXP_")"
- . I STAT="A",+ONSETDT S X=ONSETDT D REGDT4^GMTSU S ADDINFO="Onset "_X
- . I STAT="I",+RESDT S X=RESDT D REGDT4^GMTSU S ADDINFO="Resolved "_X
- . S GMPXICDF=$$UP($G(GMPXICDF))
- . S GMTSTXTF=$S(($G(GMPXICDF)="T")!($G(GMPXICDF)["TEXT ONLY"):1,1:0)
- . I $G(GMPXICDF)]"",($G(GMPXICDF)'="N")!($G(GMPXICDF)["NONE"),GMDIAG]"" D
- . . D GETICDDX^GMTSPXU1(.GMDIAG,$G(GMPXICDF),"",GMTSDINT,GMTSCSYS) S GMICD=GMDIAG
- . I $G(GMTSTXTF)=0 S GMDIAC=$P($G(GMICD),"-",1),GMDIAT=$P($G(GMICD),"-",2,299)
- . S LEX=$G(^TMP("GMPLHS",$J,GMREC,"L"))
- . S NARR=""
- . S:$G(GMPXNARR)'="N"!(LEX["Unresolved") NARR=$G(^TMP("GMPLHS",$J,GMREC,"N"))
- . S LEXI=+LEX,LEX=$P(LEX,"^",2) S:$$UP(LEX)["UNRESOLVED"!(+LEXI'>1) (LEXI,LEX)=""
- . S (CODE,GMDIAS,GMDSMS,GMDSM)="" S:+LEXI>0 GMDSM=$$DSMONE^LEXU(+LEXI)
- . S:GMDIAC["799.9" GMDSM=""
- . S:$L(GMDSM)>2&(GMDSM'[".") GMDSM=GMDSM_"."
- . S:$L(GMDIAC) GMDIAS="("_GMTSILBL_GMDIAC_")"
- . S:$L(GMDSM) GMDSMS="(DSM "_GMDSM_")"
- . S:$L(GMDIAC)&($L(GMDSM))&(GMDIAC=GMDSM) GMDIAS=GMDIAC,GMDSMS=""
- . I $G(^TMP("GMPLHS",$J,GMREC,0,"ICD9"))="" D
- . . S:$L(GMDIAC)&$S($L(GMSCT):1,$L(GMVHAT):1,1:0) GMDIAS=$S($L(GMSCT):"(SCT ",1:"(VHAT ")_GMSCT_") ("_GMTSILBL_GMDIAC_")"
- . E I $L(GMDIAC)&$S($L(GMSCT):1,$L(GMVHAT):1,1:0) D
- . . S GMDIAS=$S($L(GMSCT):"(SCT ",1:"(VHAT ")_GMSCT_") ("_GMTSILBL_GMDIAC
- . . N T S T=0 F S T=$O(^TMP("GMPLHS",$J,GMREC,T)) Q:'+T D
- . . . S GMDIAS=GMDIAS_"/"_$P($G(^TMP("GMPLHS",$J,GMREC,T,"ICD9")),U,1)
- . . S GMDIAS=GMDIAS_")"
- . S:$L(GMDIAS) CODE=GMDIAS S:$L(GMDSMS) CODE=CODE_" "_GMDSMS F Q:$E(CODE,1)'=" " S CODE=$E(CODE,2,$L(CODE))
- . S:$L(LEX)&($L(CODE)) LEX=LEX_" "_CODE
- . S:$L(GMDIAT)&($L(CODE)) GMICD=GMDIAT_" "_CODE
- . ; Unresolved or Unspecified
- . I GMDIAC["799.9",$L($G(NARR)) D
- . . N UNARR S UNARR=$$UP(NARR)
- . . I UNARR["UNKNOWN AND UNSPECIFIED"!(UNARR["UNKNOWN OR UNSPECIFIED")!(UNARR["MORBIDITY OR MORTALITY") D Q
- . . . S GMICD=GMDIAT_" "_CODE,NARR=""
- . . S GMICD=$$UP($E(NARR,1))_$E(NARR,2,$L(NARR))_" "_CODE
- . . S:$L(LEX) GMICD=LEX S NARR=""
- . ; Specified by Lexicon
- . I GMDIAC'["799.9",$L($G(LEX)) D
- . . S GMICD=LEX,NARR=""
- . ; Specified by Provider Narrative
- . I GMDIAC'["799.9",'$L($G(LEX)) D
- . . S:$L(NARR)&($$UP(GMDIAT)'=$$UP(NARR)) GMICD=$S($$UP($G(GMPXICDF))="C"!($$UP($G(GMPXICDF))="CODE ONLY"):"("_GMTSILBL_GMICD_"); ",$L($G(GMDIAT))<1:"",1:GMICD_"; ")_NARR S NARR=""
- . S:$G(IOST)["P-"&(EXP["MST") EXT=$$RM(EXP)
- . S:$L(GMICD)&($L(EXP)) GMICD=GMICD_EXP
- . S:$L(GMICD) GMICD=GMICD_$S($G(ADDINFO)]"":", "_ADDINFO,1:""),NARR=""
- . S GMICD=$$RF(GMICD)
- . D TXTFMT^GMTSPXU1(GMICD,$G(NARR),GMTSICL,GMTAB,DIWL)
- . I '$D(^UTILITY($J,"W")) Q
- . S GMTSX=0,LINE1=1
- . F S GMTSX=$O(^UTILITY($J,"W",DIWL,GMTSX)) Q:GMTSX'>0!$D(GMTSQIT) D
- . . D:LINE1 L1 D:'LINE1 LN S LINE1=0
- . D DC
- . K ^UTILITY($J,"W")
- . D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG SUBHDR2 W !
- Q
- L1 ; Line #1 Problem, date, provider
- D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG SUBHDR2 W:STATUS="ALL" STAT W ?3,$G(^UTILITY($J,"W",DIWL,GMTSX,0)),?53,LASTMDT,?65,$E(PROV,1,15),! Q
- LN ; Line >1 Problem (other)
- D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG SUBHDR2 W ?3,$G(^UTILITY($J,"W",DIWL,GMTSX,0)),! Q
- ;
- DC ; Comments are displayed if there are any
- N LOC,GMR,NODE,DATE,X,UCNT,CNT,CMT,T,I S LOC="",CNT=0
- F S LOC=$O(^TMP("GMPLHS",$J,GMREC,"C",LOC)) Q:LOC']"" D Q:$D(GMTSQIT)
- . S (CNT,UCNT)=0 S:+($O(^TMP("GMPLHS",$J,GMREC,"C",LOC," "),-1))>1 UCNT=1
- . S GMR=0 F S GMR=$O(^TMP("GMPLHS",$J,GMREC,"C",LOC,GMR)) Q:+GMR'>0 D Q:$D(GMTSQIT)
- . . S NODE=$G(^TMP("GMPLHS",$J,GMREC,"C",LOC,GMR,0)) Q:NODE']""
- . . S CMT=$P(NODE,U) I $L($G(CMT)) D LC
- Q
- LC ; List Comments (unnumbered and numbered)
- S CNT=CNT+1 K ^UTILITY($J,"W") D:UCNT CF(CNT,CMT) D:'UCNT CF(0,CMT)
- I $D(^UTILITY($J,"W",0)) N I,T S I=0 F S I=$O(^UTILITY($J,"W",0,I)) Q:+I=0 D
- . S T=$$RT($G(^UTILITY($J,"W",0,I,0))) Q:'$L(T) D CKP^GMTSUP Q:$D(GMTSQIT) D:GMTSNPG SUBHDR2 W:I=1 ?3 W:I>1 ?7 W $G(T),!
- Q
- CF(GMC,GMT) ; Formats GMC (count) and GMT (text) together
- S GMC=+($G(GMC)),GMT=$G(GMT) Q:'$L(GMT) S GMT=$$LD(GMT)
- N GMCOL,DIWL,DIWR,DIWF,X S GMCOL=34,DIWL=0,DIWR=80-(GMCOL) K ^UTILITY($J,"W")
- S:+($G(GMC))=0 X=" "_GMT S:+($G(GMC))>0 X=$J(GMC,2)_". "_GMT D:$G(X)]"" ^DIWP
- Q
- ;
- SUBHDR ; Subheader for Problem List Component
- N NUM,TOT,NODE S NODE=$G(^TMP("GMPLHS",$J,STATUS,0)) S NUM=$P(NODE,U),TOT=$P(NODE,U,2)
- D CKP^GMTSUP Q:$D(GMTSQIT) S:TOT>NUM NUM=NUM_" of "_TOT W ?50,NUM_$S(STATUS="A":" Active",STATUS="I":" Inactive",1:"")_" Problems",!
- SUBHDR2 ; Will be written on new pages
- D CKP^GMTSUP Q:$D(GMTSQIT) W:STATUS="ALL" "ST" W ?3,"PROBLEM",?53,"LAST MOD",?65,"PROVIDER",! Q
- ;
- RM(X) ; Remove MST
- S X=$G(X) F Q:X'["MST" S X=$P(X,"MST",1)_$P(X,"MST",2)
- F Q:X'["//" S X=$P(X,"//",1)_"/"_$P(X,"//",2)
- F Q:$E(X,$L(X))'="/" S X=$E(X,1,($L(X)-1))
- F Q:$E(X,1)'="/" S X=$E(X,2,$L(X))
- Q X
- RF(X) ; Remove Leading Spaces/Punctuation
- F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
- F Q:$E(X,1)'=";" S X=$E(X,2,$L(X))
- F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
- S X=$$LD(X) Q X
- LD(X) ; Uppercase Leading Character
- Q $TR($E(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$E(X,2,$L(X))
- RT(X) ; Right Trim Spaces
- S X=$G(X) F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
- Q X
- UP(X) ; Uppercase
- Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSPLST 8084 printed Jan 18, 2025@03:00:29 Page 2
- GMTSPLST ; SLC/JER,KER,TC - Problem List ;07/02/13 09:56
- +1 ;;2.7;Health Summary;**28,35,52,86,101**;Oct 20, 1995;Build 12
- +2 ;
- +3 ; External References
- +4 ; DBIA 10011 ^DIWP
- +5 ; DBIA 1183 GETLIST^GMPLHS
- +6 ; DBIA 1573 $$DSMONE^LEXU
- +7 ;
- +8 ; Variable NEWed/KILLed Elsewhere
- +9 ; DFN, GMPXICDF, GMPXNARR, GMTSNPG, GMTSQIT
- +10 ;
- ACTIVE ; Get Active Problems
- +1 NEW STATUS
- SET STATUS="A"
- DO MAIN
- QUIT
- INACT ; Get Inactive Problems
- +1 NEW STATUS
- SET STATUS="I"
- DO MAIN
- QUIT
- ALL ; Get All Problems (Active and Inactive)
- +1 NEW STATUS
- SET STATUS="ALL"
- DO MAIN
- QUIT
- MAIN ; Driver
- +1 DO GETLIST^GMPLHS(DFN,STATUS)
- if '$DATA(^TMP("GMPLHS",$JOB))
- QUIT
- DO SUBHDR
- DO WRT
- KILL ^TMP("GMPLHS",$JOB)
- QUIT
- +2 ;
- WRT ; Writes Problem List Component,X
- +1 ;
- +2 ; ^TMP("GMPLHS",$J,#,0)=
- +3 ; Piece 1: Diagnosis
- +4 ; 2: Date Last Modified
- +5 ; 3: Site
- +6 ; 4: Date Entered
- +7 ; 5: Status
- +8 ; 6: Date of Onset
- +9 ; 7: Responsible Provider
- +10 ; 8: Service
- +11 ; 9: Service Abbreviation
- +12 ; 10: Date Resolved
- +13 ; 11: Clinic
- +14 ; 12: Date Recorded
- +15 ; 13: Problem - Lexicon Term
- +16 ; 14: Exposure Combined String
- +17 ; 15: SNOMED-CT Concept Code
- +18 ; 16: SNOMED-CT Preferred Text
- +19 ; 17: ICD-9-CM Code
- +20 ; 18: ICD-9-CM Description
- +21 ; 19: VHAT Concept Code
- +22 ; 20: VHAT Preferred Text
- +23 ; 21: Date of Interest
- +24 ; 22: Coding System (of Primary diagnosis)
- +25 ;
- +26 ; ^TMP("GMPLHS",$J,#,#,"ICD9") Other multiple mapped ICD-9-CM codes
- +27 ; ^TMP("GMPLHS",$J,#,"L") Lexicon Term
- +28 ; ^TMP("GMPLHS",$J,#,"N") Provider Narrative
- +29 ; ^TMP("GMPLHS",$J,#,"C",LOC,#,0)) Comments
- +30 ;
- +31 NEW GMREC,GMTSICL,GMTAB,LINE1,DIWL,GMTSTXTF
- +32 SET GMTSICL=32
- SET DIWL=0
- SET GMTAB=0
- SET GMREC=0
- SET GMTSTXTF=0
- +33 FOR
- SET GMREC=$ORDER(^TMP("GMPLHS",$JOB,GMREC))
- if GMREC'>0
- QUIT
- Begin DoDot:1
- +34 NEW GMNODE,GMDIAG,GMDIAC,GMDIAT,GMDIAS,LASTMDT,STAT,ONSETDT,PROV,SERV,GMSCT,GMVHAT,GMTSDINT,GMTSCSYS
- +35 NEW RESDT,NARR,GMICD,GMDSM,GMDSMS,CODE,LEXI,LEX,PLIFN,ADDINFO,EXP,GMTSX,X,GMDIAC,GMDIAT,GMTSILBL
- +36 SET (GMDIAC,GMDIAT)=""
- +37 SET GMNODE=$GET(^TMP("GMPLHS",$JOB,GMREC,0))
- +38 if GMNODE']""
- QUIT
- +39 SET GMDIAG=$PIECE(GMNODE,U)
- SET LASTMDT=$PIECE(GMNODE,U,2)
- SET STAT=$PIECE(GMNODE,U,5)
- +40 SET GMTSDINT=$PIECE(GMNODE,U,21)
- SET GMTSCSYS=$PIECE(GMNODE,U,22)
- SET GMTSILBL=$SELECT($GET(GMTSCSYS)="ICD":"ICD-9-CM ",1:"ICD-10-CM ")
- +41 SET X=LASTMDT
- DO REGDT4^GMTSU
- SET LASTMDT=X
- +42 SET ONSETDT=$PIECE(GMNODE,U,6)
- SET PROV=$PIECE(GMNODE,U,7)
- +43 SET RESDT=$PIECE(GMNODE,U,10)
- SET GMICD=""
- SET GMSCT=$PIECE(GMNODE,U,15)
- SET GMVHAT=$PIECE(GMNODE,U,19)
- +44 SET EXP=$PIECE(GMNODE,U,14)
- if $LENGTH(EXP)
- SET EXP=" ("_EXP_")"
- +45 IF STAT="A"
- IF +ONSETDT
- SET X=ONSETDT
- DO REGDT4^GMTSU
- SET ADDINFO="Onset "_X
- +46 IF STAT="I"
- IF +RESDT
- SET X=RESDT
- DO REGDT4^GMTSU
- SET ADDINFO="Resolved "_X
- +47 SET GMPXICDF=$$UP($GET(GMPXICDF))
- +48 SET GMTSTXTF=$SELECT(($GET(GMPXICDF)="T")!($GET(GMPXICDF)["TEXT ONLY"):1,1:0)
- +49 IF $GET(GMPXICDF)]""
- IF ($GET(GMPXICDF)'="N")!($GET(GMPXICDF)["NONE")
- IF GMDIAG]""
- Begin DoDot:2
- +50 DO GETICDDX^GMTSPXU1(.GMDIAG,$GET(GMPXICDF),"",GMTSDINT,GMTSCSYS)
- SET GMICD=GMDIAG
- End DoDot:2
- +51 IF $GET(GMTSTXTF)=0
- SET GMDIAC=$PIECE($GET(GMICD),"-",1)
- SET GMDIAT=$PIECE($GET(GMICD),"-",2,299)
- +52 SET LEX=$GET(^TMP("GMPLHS",$JOB,GMREC,"L"))
- +53 SET NARR=""
- +54 if $GET(GMPXNARR)'="N"!(LEX["Unresolved")
- SET NARR=$GET(^TMP("GMPLHS",$JOB,GMREC,"N"))
- +55 SET LEXI=+LEX
- SET LEX=$PIECE(LEX,"^",2)
- if $$UP(LEX)["UNRESOLVED"!(+LEXI'>1)
- SET (LEXI,LEX)=""
- +56 SET (CODE,GMDIAS,GMDSMS,GMDSM)=""
- if +LEXI>0
- SET GMDSM=$$DSMONE^LEXU(+LEXI)
- +57 if GMDIAC["799.9"
- SET GMDSM=""
- +58 if $LENGTH(GMDSM)>2&(GMDSM'[".")
- SET GMDSM=GMDSM_"."
- +59 if $LENGTH(GMDIAC)
- SET GMDIAS="("_GMTSILBL_GMDIAC_")"
- +60 if $LENGTH(GMDSM)
- SET GMDSMS="(DSM "_GMDSM_")"
- +61 if $LENGTH(GMDIAC)&($LENGTH(GMDSM))&(GMDIAC=GMDSM)
- SET GMDIAS=GMDIAC
- SET GMDSMS=""
- +62 IF $GET(^TMP("GMPLHS",$JOB,GMREC,0,"ICD9"))=""
- Begin DoDot:2
- +63 if $LENGTH(GMDIAC)&$SELECT($LENGTH(GMSCT)
- SET GMDIAS=$SELECT($LENGTH(GMSCT):"(SCT ",1:"(VHAT ")_GMSCT_") ("_GMTSILBL_GMDIAC_")"
- End DoDot:2
- +64 IF '$TEST
- IF $LENGTH(GMDIAC)&$SELECT($LENGTH(GMSCT):1,$LENGTH(GMVHAT):1,1:0)
- Begin DoDot:2
- +65 SET GMDIAS=$SELECT($LENGTH(GMSCT):"(SCT ",1:"(VHAT ")_GMSCT_") ("_GMTSILBL_GMDIAC
- +66 NEW T
- SET T=0
- FOR
- SET T=$ORDER(^TMP("GMPLHS",$JOB,GMREC,T))
- if '+T
- QUIT
- Begin DoDot:3
- +67 SET GMDIAS=GMDIAS_"/"_$PIECE($GET(^TMP("GMPLHS",$JOB,GMREC,T,"ICD9")),U,1)
- End DoDot:3
- +68 SET GMDIAS=GMDIAS_")"
- End DoDot:2
- +69 if $LENGTH(GMDIAS)
- SET CODE=GMDIAS
- if $LENGTH(GMDSMS)
- SET CODE=CODE_" "_GMDSMS
- FOR
- if $EXTRACT(CODE,1)'=" "
- QUIT
- SET CODE=$EXTRACT(CODE,2,$LENGTH(CODE))
- +70 if $LENGTH(LEX)&($LENGTH(CODE))
- SET LEX=LEX_" "_CODE
- +71 if $LENGTH(GMDIAT)&($LENGTH(CODE))
- SET GMICD=GMDIAT_" "_CODE
- +72 ; Unresolved or Unspecified
- +73 IF GMDIAC["799.9"
- IF $LENGTH($GET(NARR))
- Begin DoDot:2
- +74 NEW UNARR
- SET UNARR=$$UP(NARR)
- +75 IF UNARR["UNKNOWN AND UNSPECIFIED"!(UNARR["UNKNOWN OR UNSPECIFIED")!(UNARR["MORBIDITY OR MORTALITY")
- Begin DoDot:3
- +76 SET GMICD=GMDIAT_" "_CODE
- SET NARR=""
- End DoDot:3
- QUIT
- +77 SET GMICD=$$UP($EXTRACT(NARR,1))_$EXTRACT(NARR,2,$LENGTH(NARR))_" "_CODE
- +78 if $LENGTH(LEX)
- SET GMICD=LEX
- SET NARR=""
- End DoDot:2
- +79 ; Specified by Lexicon
- +80 IF GMDIAC'["799.9"
- IF $LENGTH($GET(LEX))
- Begin DoDot:2
- +81 SET GMICD=LEX
- SET NARR=""
- End DoDot:2
- +82 ; Specified by Provider Narrative
- +83 IF GMDIAC'["799.9"
- IF '$LENGTH($GET(LEX))
- Begin DoDot:2
- +84 if $LENGTH(NARR)&($$UP(GMDIAT)'=$$UP(NARR))
- SET GMICD=$SELECT($$UP($GET(GMPXICDF))="C"!($$UP($GET(GMPXICDF))="CODE ONLY"):"("_GMTSILBL_GMICD_"); ",$LENGTH($GET(GMDIAT))<1:"",1:GMICD_"; ")_NARR
- SET NARR=""
- End DoDot:2
- +85 if $GET(IOST)["P-"&(EXP["MST")
- SET EXT=$$RM(EXP)
- +86 if $LENGTH(GMICD)&($LENGTH(EXP))
- SET GMICD=GMICD_EXP
- +87 if $LENGTH(GMICD)
- SET GMICD=GMICD_$SELECT($GET(ADDINFO)]"":", "_ADDINFO,1:"")
- SET NARR=""
- +88 SET GMICD=$$RF(GMICD)
- +89 DO TXTFMT^GMTSPXU1(GMICD,$GET(NARR),GMTSICL,GMTAB,DIWL)
- +90 IF '$DATA(^UTILITY($JOB,"W"))
- QUIT
- +91 SET GMTSX=0
- SET LINE1=1
- +92 FOR
- SET GMTSX=$ORDER(^UTILITY($JOB,"W",DIWL,GMTSX))
- if GMTSX'>0!$DATA(GMTSQIT)
- QUIT
- Begin DoDot:2
- +93 if LINE1
- DO L1
- if 'LINE1
- DO LN
- SET LINE1=0
- End DoDot:2
- +94 DO DC
- +95 KILL ^UTILITY($JOB,"W")
- +96 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- DO SUBHDR2
- WRITE !
- End DoDot:1
- if $DATA(GMTSQIT)
- QUIT
- +97 QUIT
- L1 ; Line #1 Problem, date, provider
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- DO SUBHDR2
- if STATUS="ALL"
- WRITE STAT
- WRITE ?3,$GET(^UTILITY($JOB,"W",DIWL,GMTSX,0)),?53,LASTMDT,?65,$EXTRACT(PROV,1,15),!
- QUIT
- LN ; Line >1 Problem (other)
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- DO SUBHDR2
- WRITE ?3,$GET(^UTILITY($JOB,"W",DIWL,GMTSX,0)),!
- QUIT
- +2 ;
- DC ; Comments are displayed if there are any
- +1 NEW LOC,GMR,NODE,DATE,X,UCNT,CNT,CMT,T,I
- SET LOC=""
- SET CNT=0
- +2 FOR
- SET LOC=$ORDER(^TMP("GMPLHS",$JOB,GMREC,"C",LOC))
- if LOC']""
- QUIT
- Begin DoDot:1
- +3 SET (CNT,UCNT)=0
- if +($ORDER(^TMP("GMPLHS",$JOB,GMREC,"C",LOC," "),-1))>1
- SET UCNT=1
- +4 SET GMR=0
- FOR
- SET GMR=$ORDER(^TMP("GMPLHS",$JOB,GMREC,"C",LOC,GMR))
- if +GMR'>0
- QUIT
- Begin DoDot:2
- +5 SET NODE=$GET(^TMP("GMPLHS",$JOB,GMREC,"C",LOC,GMR,0))
- if NODE']""
- QUIT
- +6 SET CMT=$PIECE(NODE,U)
- IF $LENGTH($GET(CMT))
- DO LC
- End DoDot:2
- if $DATA(GMTSQIT)
- QUIT
- End DoDot:1
- if $DATA(GMTSQIT)
- QUIT
- +7 QUIT
- LC ; List Comments (unnumbered and numbered)
- +1 SET CNT=CNT+1
- KILL ^UTILITY($JOB,"W")
- if UCNT
- DO CF(CNT,CMT)
- if 'UCNT
- DO CF(0,CMT)
- +2 IF $DATA(^UTILITY($JOB,"W",0))
- NEW I,T
- SET I=0
- FOR
- SET I=$ORDER(^UTILITY($JOB,"W",0,I))
- if +I=0
- QUIT
- Begin DoDot:1
- +3 SET T=$$RT($GET(^UTILITY($JOB,"W",0,I,0)))
- if '$LENGTH(T)
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMTSNPG
- DO SUBHDR2
- if I=1
- WRITE ?3
- if I>1
- WRITE ?7
- WRITE $GET(T),!
- End DoDot:1
- +4 QUIT
- CF(GMC,GMT) ; Formats GMC (count) and GMT (text) together
- +1 SET GMC=+($GET(GMC))
- SET GMT=$GET(GMT)
- if '$LENGTH(GMT)
- QUIT
- SET GMT=$$LD(GMT)
- +2 NEW GMCOL,DIWL,DIWR,DIWF,X
- SET GMCOL=34
- SET DIWL=0
- SET DIWR=80-(GMCOL)
- KILL ^UTILITY($JOB,"W")
- +3 if +($GET(GMC))=0
- SET X=" "_GMT
- if +($GET(GMC))>0
- SET X=$JUSTIFY(GMC,2)_". "_GMT
- if $GET(X)]""
- DO ^DIWP
- +4 QUIT
- +5 ;
- SUBHDR ; Subheader for Problem List Component
- +1 NEW NUM,TOT,NODE
- SET NODE=$GET(^TMP("GMPLHS",$JOB,STATUS,0))
- SET NUM=$PIECE(NODE,U)
- SET TOT=$PIECE(NODE,U,2)
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if TOT>NUM
- SET NUM=NUM_" of "_TOT
- WRITE ?50,NUM_$SELECT(STATUS="A":" Active",STATUS="I":" Inactive",1:"")_" Problems",!
- SUBHDR2 ; Will be written on new pages
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if STATUS="ALL"
- WRITE "ST"
- WRITE ?3,"PROBLEM",?53,"LAST MOD",?65,"PROVIDER",!
- QUIT
- +2 ;
- RM(X) ; Remove MST
- +1 SET X=$GET(X)
- FOR
- if X'["MST"
- QUIT
- SET X=$PIECE(X,"MST",1)_$PIECE(X,"MST",2)
- +2 FOR
- if X'["//"
- QUIT
- SET X=$PIECE(X,"//",1)_"/"_$PIECE(X,"//",2)
- +3 FOR
- if $EXTRACT(X,$LENGTH(X))'="/"
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +4 FOR
- if $EXTRACT(X,1)'="/"
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +5 QUIT X
- RF(X) ; Remove Leading Spaces/Punctuation
- +1 FOR
- if $EXTRACT(X,1)'=" "
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +2 FOR
- if $EXTRACT(X,1)'=";"
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +3 FOR
- if $EXTRACT(X,1)'=" "
- QUIT
- SET X=$EXTRACT(X,2,$LENGTH(X))
- +4 SET X=$$LD(X)
- QUIT X
- LD(X) ; Uppercase Leading Character
- +1 QUIT $TRANSLATE($EXTRACT(X,1),"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")_$EXTRACT(X,2,$LENGTH(X))
- RT(X) ; Right Trim Spaces
- +1 SET X=$GET(X)
- FOR
- if $EXTRACT(X,$LENGTH(X))'=" "
- QUIT
- SET X=$EXTRACT(X,1,($LENGTH(X)-1))
- +2 QUIT X
- UP(X) ; Uppercase
- +1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")