- GMTSALG ; SLC/DLT,KER - Allergies ; 01/06/2003
- ;;2.7;Health Summary;**9,28,49,58**;Oct 20, 1995
- ;
- ; External References
- ; DBIA 10096 ^%ZOSF("TEST"
- ; DBIA 10035 ^DPT(
- ; DBIA 905 ^GMR(120.8
- ; DBIA 2056 $$GET1^DIQ (file #120.86 and #200)
- ; DBIA 10011 ^DIWP
- ; DBIA 10099 EN1^GMRADPT
- ; DBIA 10060 ^VA(200,
- ; DBIA 3449 ^GMR(120.86,
- ;
- ALLRG ; Allergies
- N X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
- N GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
- N ALLRG,TITLE,JJ K GMTSA S (SEQ,ALLRG)=0,TITLE="ALLERGY/ADVERSE REACTION (AR)"
- S X="GMRADPT" X ^%ZOSF("TEST")
- I $T D Q:$D(GMTSQIT)
- . D GETALLRG D:ALLRG TITLE,ALLRGP D:'ALLRG&($L($G(GMTSALAS))) TITLE,NKA
- I 'ALLRG,'$L($G(GMTSALAS)) D
- . I $D(GMTSPNF)&('ALLRG) D CKP^GMTSUP Q:$D(GMTSQIT) W "Unknown, please evaluate",!
- K ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMTSALNM,GMTSNODE,GMTSPRT,I,II,JJ,KK,L,M,MX,N,Z,X,SEQ,GMTSA,ALLRG,TITLE,GMRA,GMRAL,GMTSEACT,GMTSMECH,GMTSTY,GMTSPFN,GMTSAL,GMTSCNT,GMTSLN,ODT
- Q
- ALLRGP ; Allergy Print
- S II="" F S II=$O(GMTSAL(II)) Q:II']"" I $O(GMTSAL(II,""))]"" D
- . D CKP^GMTSUP Q:$D(GMTSQIT) W !?2,$S(II="D":"Drug:",II="DF":"Drug/Food:",II="DFO":"Drug/Food/Other:",II="DO":"Drug/Other:",II="F":"Food:",II="FO":"Food/Other:",II="O":"Other:",1:II_":")
- . S JJ="" F S JJ=$O(GMTSAL(II,JJ)) Q:JJ="" D
- .. N WKK S KK="" F S KK=$O(GMTSAL(II,JJ,KK)) Q:KK="" D
- ... S L=0 F S L=$O(GMTSAL(II,JJ,KK,L)) Q:'L D CKP^GMTSUP Q:$D(GMTSQIT) D AUTOV W !?5,JJ_": " S:$L(KK)>30 WKK=KK,WKK=$$WRAP^GMTSORC(WKK,30) W ?24,$S($L(KK)>30:$P(WKK,"|"),1:KK) D
- .... I GMTSAV=1 W " (AV"
- .... E W $S($P(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$P(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
- .... W $S($P($G(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$P($G(^(0)),U,6)="o":"/Observed)",1:")")
- .... I $L($P($G(WKK),"|",2)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,?24,$P(WKK,"|",2)
- .... S (M,MX,ALL)=0 F S M=$O(GMTSAL(II,JJ,KK,L,"S",M)) Q:M="" D Q:$D(GMTSQIT)
- ..... I ALL=0 D CKP^GMTSUP Q:$D(GMTSQIT) W !?27
- ..... S MX=MX+1
- ..... W:MX>1 ", "
- ..... S N=$P(GMTSAL(II,JJ,KK,L,"S",M),";")
- ..... S ALL=1 I (74)'>($X+$L(N)) D CKP^GMTSUP Q:$D(GMTSQIT) W !,?27,N Q
- ..... S ALL=1 W N
- .... D SIGBLK($P(GMTSAFN,U,5))
- .... D CKP^GMTSUP Q:$D(GMTSQIT) W !,?24,"Date/Time: " S ODT=$P(GMTSAFN,U,4) S X=ODT D REGDTM4^GMTSU W X,!
- ....S CC="" F S CC=$O(^GMR(120.8,GMTSALNM,26,"B",CC)) Q:CC="" D CKP^GMTSUP Q:$D(GMTSQIT) W !,?24,"Comments at: " S X=CC D REGDTM4^GMTSU S CD=X S CCC=0 F S CCC=$O(^GMR(120.8,GMTSALNM,26,"B",CC,CCC)) Q:'CCC D TEXT
- Q
- NKA ; No known allergies
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L($G(GMTSALAS))!($L($G(GMTSALAD))) !
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L($G(GMTSALAS)) ?22,$G(GMTSALAS),!
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L($G(GMTSALAS))!($L($G(GMTSALAD)))!($L($G(GMTSALAW))) ?24,"Assessment date: ",$G(GMTSALAD),!
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L($G(GMTSALAW)) ?28,"Assessed by: ",GMTSALAW,!
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L($G(GMTSALAW))&($L($G(GMTSALAT))) ?34,"Title: ",GMTSALAT,!
- Q
- GETALLRG ; Get Allergies
- S GMRA="0^0^111" D EN1^GMRADPT I GMRAL="" S ALLRG=0 Q
- I +($G(DFN))>0,+($G(GMRAL))=0 D ALLAS S ALLRG=0 Q
- I $D(GMRAL)>9 D
- . S I=0 F GMTSCNT=1:1 S I=$O(GMRAL(I)) Q:'I D
- .. S GMTSTY=$P(GMRAL(I),U,7) Q:GMTSTY']""
- .. S GMTSEACT=$P(GMRAL(I),U,2) Q:GMTSEACT']""
- .. S GMTSMECH=$P($P(GMRAL(I),U,8),";")
- .. S:GMTSMECH']"" GMTSMECH="UNKNOWN"
- .. S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
- .. S JJ=0 F S JJ=$O(GMRAL(I,"S",JJ)) Q:'JJ S GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"S",JJ)=GMRAL(I,"S",JJ)
- .. S ALLRG=1
- Q
- ALLAS ; Allergy Assessment
- N X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU S (GMTSALAS,GMTSALAD,GMTSALAW)="" S GMTSALAS="No known allergies"
- S GMTSALAD=$$GET1^DIQ(120.86,+($G(DFN)),3,"I",,"GMTSALG2") S:$D(GMTSALG2) GMTSALAD="" S:+GMTSALAD=0 GMTSALAD=""
- I +GMTSALAD>0 S X=GMTSALAD D REGDT4^GMTSU S GMTSALAD=X
- S GMTSAU=$$GET1^DIQ(120.86,+($G(DFN)),2,"I")
- S GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
- S GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
- S:$D(GMTSALG3) (GMTSALAW,GMTSALAT)=""
- Q
- AUTOV ; Autoverify
- S GMTSAV=0,GMTSALNM=$P(GMTSAL(II,JJ,KK,L),U),GMTSAFN=$G(^GMR(120.8,GMTSALNM,0))
- I $P(GMTSAFN,U,18)="",$P(GMTSAFN,U,16)=1 S GMTSAV=1
- Q
- TITLE ; Print title
- D CKP^GMTSUP Q:$D(GMTSQIT)
- I $D(GMTSPNF) W ?21,TITLE,!
- E W ?21,"Title: ",TITLE,!
- Q
- TEXT ; Setup for print of allergy comments
- W ?31,CD D CKP^GMTSUP Q:$D(GMTSQIT)
- K ^UTILITY($J,"W") S GMTSLN=0 F S GMTSLN=$O(^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN)) Q:'GMTSLN S GMTSPRT=^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN,0) D FORMAT
- I $D(^UTILITY($J,"W")) F GMTSLN=1:1:^UTILITY($J,"W",DIWL) D LINE Q:$D(GMTSQIT)
- K ^UTILITY($J,"W")
- Q:'GMTSLN
- W ! Q
- FORMAT ; Formats each line
- S DIWL=3,DIWR=80,DIWF="C58",X=GMTSPRT D ^DIWP
- Q
- LINE ; Writes formatted lines of text
- D CKP^GMTSUP Q:$D(GMTSQIT) W !,?24,^UTILITY($J,"W",DIWL,GMTSLN,0)
- Q
- SIGBLK(GMTSALF) ; Signature block
- Q:+GMTSALF'>0 N GMTSSB,GMTSST,GMTSSN S GMTSSB=$$GET1^DIQ(200,(+GMTSALF_","),20.2),GMTSST=$$GET1^DIQ(200,(+GMTSALF_","),20.3),GMTSSN=$$GET1^DIQ(200,(+GMTSALF_","),.01)
- D CKP^GMTSUP Q:$D(GMTSQIT) W !!,?24,"Originator: ",$S(GMTSSB'="":GMTSSB,1:GMTSSN)
- D CKP^GMTSUP Q:$D(GMTSQIT) W:$L(GMTSST) !,?24,"Title: ",GMTSST
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSALG 5387 printed Feb 18, 2025@23:23:26 Page 2
- GMTSALG ; SLC/DLT,KER - Allergies ; 01/06/2003
- +1 ;;2.7;Health Summary;**9,28,49,58**;Oct 20, 1995
- +2 ;
- +3 ; External References
- +4 ; DBIA 10096 ^%ZOSF("TEST"
- +5 ; DBIA 10035 ^DPT(
- +6 ; DBIA 905 ^GMR(120.8
- +7 ; DBIA 2056 $$GET1^DIQ (file #120.86 and #200)
- +8 ; DBIA 10011 ^DIWP
- +9 ; DBIA 10099 EN1^GMRADPT
- +10 ; DBIA 10060 ^VA(200,
- +11 ; DBIA 3449 ^GMR(120.86,
- +12 ;
- ALLRG ; Allergies
- +1 NEW X,GMTSALAS,GMTSALAD,GMTSALAW,GMTSALAT,GMTSAV,GMTSAFN,GMRAL,GMTSAL
- +2 NEW GMTSALNM,GMTSCNT,GMTSEACT,GMTSLN,GMTSMECH,GMTSPRT,GMTSTY,CC,C,KK
- +3 NEW ALLRG,TITLE,JJ
- KILL GMTSA
- SET (SEQ,ALLRG)=0
- SET TITLE="ALLERGY/ADVERSE REACTION (AR)"
- +4 SET X="GMRADPT"
- XECUTE ^%ZOSF("TEST")
- +5 IF $TEST
- Begin DoDot:1
- +6 DO GETALLRG
- if ALLRG
- DO TITLE
- DO ALLRGP
- if 'ALLRG&($LENGTH($GET(GMTSALAS)))
- DO TITLE
- DO NKA
- End DoDot:1
- if $DATA(GMTSQIT)
- QUIT
- +7 IF 'ALLRG
- IF '$LENGTH($GET(GMTSALAS))
- Begin DoDot:1
- +8 IF $DATA(GMTSPNF)&('ALLRG)
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE "Unknown, please evaluate",!
- End DoDot:1
- +9 KILL ALL,CC,CCC,CD,DIWF,DIWL,DIWR,GMTSALF,GMTSALNM,GMTSNODE,GMTSPRT,I,II,JJ,KK,L,M,MX,N,Z,X,SEQ,GMTSA,ALLRG,TITLE,GMRA,GMRAL,GMTSEACT,GMTSMECH,GMTSTY,GMTSPFN,GMTSAL,GMTSCNT,GMTSLN,ODT
- +10 QUIT
- ALLRGP ; Allergy Print
- +1 SET II=""
- FOR
- SET II=$ORDER(GMTSAL(II))
- if II']""
- QUIT
- IF $ORDER(GMTSAL(II,""))]""
- Begin DoDot:1
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !?2,$SELECT(II="D":"Drug:",II="DF":"Drug/Food:",II="DFO":"Drug/Food/Other:",II="DO":"Drug/Other:",II="F":"Food:",II="FO":"Food/Other:",II="O":"Other:",1:II_":")
- +3 SET JJ=""
- FOR
- SET JJ=$ORDER(GMTSAL(II,JJ))
- if JJ=""
- QUIT
- Begin DoDot:2
- +4 NEW WKK
- SET KK=""
- FOR
- SET KK=$ORDER(GMTSAL(II,JJ,KK))
- if KK=""
- QUIT
- Begin DoDot:3
- +5 SET L=0
- FOR
- SET L=$ORDER(GMTSAL(II,JJ,KK,L))
- if 'L
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- DO AUTOV
- WRITE !?5,JJ_": "
- if $LENGTH(KK)>30
- SET WKK=KK
- SET WKK=$$WRAP^GMTSORC(WKK,30)
- WRITE ?24,$SELECT($LENGTH(KK)>30:$PIECE(WKK,"|"),1:KK)
- Begin DoDot:4
- +6 IF GMTSAV=1
- WRITE " (AV"
- +7 IF '$TEST
- WRITE $SELECT($PIECE(GMTSAL(II,JJ,KK,L),U,5)=1:" (V",$PIECE(GMTSAL(II,JJ,KK,L),U,5)=0:" (NV",1:"")
- +8 WRITE $SELECT($PIECE($GET(^GMR(120.8,GMTSALNM,0)),U,6)="h":"/Historical)",$PIECE($GET(^(0)),U,6)="o":"/Observed)",1:")")
- +9 IF $LENGTH($PIECE($GET(WKK),"|",2))
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,?24,$PIECE(WKK,"|",2)
- +10 SET (M,MX,ALL)=0
- FOR
- SET M=$ORDER(GMTSAL(II,JJ,KK,L,"S",M))
- if M=""
- QUIT
- Begin DoDot:5
- +11 IF ALL=0
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !?27
- +12 SET MX=MX+1
- +13 if MX>1
- WRITE ", "
- +14 SET N=$PIECE(GMTSAL(II,JJ,KK,L,"S",M),";")
- +15 SET ALL=1
- IF (74)'>($X+$LENGTH(N))
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,?27,N
- QUIT
- +16 SET ALL=1
- WRITE N
- End DoDot:5
- if $DATA(GMTSQIT)
- QUIT
- +17 DO SIGBLK($PIECE(GMTSAFN,U,5))
- +18 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,?24,"Date/Time: "
- SET ODT=$PIECE(GMTSAFN,U,4)
- SET X=ODT
- DO REGDTM4^GMTSU
- WRITE X,!
- +19 SET CC=""
- FOR
- SET CC=$ORDER(^GMR(120.8,GMTSALNM,26,"B",CC))
- if CC=""
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,?24,"Comments at: "
- SET X=CC
- DO REGDTM4^GMTSU
- SET CD=X
- SET CCC=0
- FOR
- SET CCC=$ORDER(^GMR(120.8,GMTSALNM,26,"B",CC,CCC))
- if 'CCC
- QUIT
- DO TEXT
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +20 QUIT
- NKA ; No known allergies
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH($GET(GMTSALAS))!($LENGTH($GET(GMTSALAD)))
- WRITE !
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH($GET(GMTSALAS))
- WRITE ?22,$GET(GMTSALAS),!
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH($GET(GMTSALAS))!($LENGTH($GET(GMTSALAD)))!($LENGTH($GET(GMTSALAW)))
- WRITE ?24,"Assessment date: ",$GET(GMTSALAD),!
- +4 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH($GET(GMTSALAW))
- WRITE ?28,"Assessed by: ",GMTSALAW,!
- +5 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH($GET(GMTSALAW))&($LENGTH($GET(GMTSALAT)))
- WRITE ?34,"Title: ",GMTSALAT,!
- +6 QUIT
- GETALLRG ; Get Allergies
- +1 SET GMRA="0^0^111"
- DO EN1^GMRADPT
- IF GMRAL=""
- SET ALLRG=0
- QUIT
- +2 IF +($GET(DFN))>0
- IF +($GET(GMRAL))=0
- DO ALLAS
- SET ALLRG=0
- QUIT
- +3 IF $DATA(GMRAL)>9
- Begin DoDot:1
- +4 SET I=0
- FOR GMTSCNT=1:1
- SET I=$ORDER(GMRAL(I))
- if 'I
- QUIT
- Begin DoDot:2
- +5 SET GMTSTY=$PIECE(GMRAL(I),U,7)
- if GMTSTY']""
- QUIT
- +6 SET GMTSEACT=$PIECE(GMRAL(I),U,2)
- if GMTSEACT']""
- QUIT
- +7 SET GMTSMECH=$PIECE($PIECE(GMRAL(I),U,8),";")
- +8 if GMTSMECH']""
- SET GMTSMECH="UNKNOWN"
- +9 SET GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT)=I_"^"_GMRAL(I)
- +10 SET JJ=0
- FOR
- SET JJ=$ORDER(GMRAL(I,"S",JJ))
- if 'JJ
- QUIT
- SET GMTSAL(GMTSTY,GMTSMECH,GMTSEACT,GMTSCNT,"S",JJ)=GMRAL(I,"S",JJ)
- +11 SET ALLRG=1
- End DoDot:2
- End DoDot:1
- +12 QUIT
- ALLAS ; Allergy Assessment
- +1 NEW X,GMTSALG1,GMTSALG2,GMTSALG3,GMTSAU
- SET (GMTSALAS,GMTSALAD,GMTSALAW)=""
- SET GMTSALAS="No known allergies"
- +2 SET GMTSALAD=$$GET1^DIQ(120.86,+($GET(DFN)),3,"I",,"GMTSALG2")
- if $DATA(GMTSALG2)
- SET GMTSALAD=""
- if +GMTSALAD=0
- SET GMTSALAD=""
- +3 IF +GMTSALAD>0
- SET X=GMTSALAD
- DO REGDT4^GMTSU
- SET GMTSALAD=X
- +4 SET GMTSAU=$$GET1^DIQ(120.86,+($GET(DFN)),2,"I")
- +5 SET GMTSALAW=$$GET1^DIQ(200,(+GMTSAU_","),.01,"E",,"GMTSALG3")
- +6 SET GMTSALAT=$$GET1^DIQ(200,(+GMTSAU_","),20.3)
- +7 if $DATA(GMTSALG3)
- SET (GMTSALAW,GMTSALAT)=""
- +8 QUIT
- AUTOV ; Autoverify
- +1 SET GMTSAV=0
- SET GMTSALNM=$PIECE(GMTSAL(II,JJ,KK,L),U)
- SET GMTSAFN=$GET(^GMR(120.8,GMTSALNM,0))
- +2 IF $PIECE(GMTSAFN,U,18)=""
- IF $PIECE(GMTSAFN,U,16)=1
- SET GMTSAV=1
- +3 QUIT
- TITLE ; Print title
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +2 IF $DATA(GMTSPNF)
- WRITE ?21,TITLE,!
- +3 IF '$TEST
- WRITE ?21,"Title: ",TITLE,!
- +4 QUIT
- TEXT ; Setup for print of allergy comments
- +1 WRITE ?31,CD
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +2 KILL ^UTILITY($JOB,"W")
- SET GMTSLN=0
- FOR
- SET GMTSLN=$ORDER(^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN))
- if 'GMTSLN
- QUIT
- SET GMTSPRT=^GMR(120.8,GMTSALNM,26,CCC,2,GMTSLN,0)
- DO FORMAT
- +3 IF $DATA(^UTILITY($JOB,"W"))
- FOR GMTSLN=1:1:^UTILITY($JOB,"W",DIWL)
- DO LINE
- if $DATA(GMTSQIT)
- QUIT
- +4 KILL ^UTILITY($JOB,"W")
- +5 if 'GMTSLN
- QUIT
- +6 WRITE !
- QUIT
- FORMAT ; Formats each line
- +1 SET DIWL=3
- SET DIWR=80
- SET DIWF="C58"
- SET X=GMTSPRT
- DO ^DIWP
- +2 QUIT
- LINE ; Writes formatted lines of text
- +1 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !,?24,^UTILITY($JOB,"W",DIWL,GMTSLN,0)
- +2 QUIT
- SIGBLK(GMTSALF) ; Signature block
- +1 if +GMTSALF'>0
- QUIT
- NEW GMTSSB,GMTSST,GMTSSN
- SET GMTSSB=$$GET1^DIQ(200,(+GMTSALF_","),20.2)
- SET GMTSST=$$GET1^DIQ(200,(+GMTSALF_","),20.3)
- SET GMTSSN=$$GET1^DIQ(200,(+GMTSALF_","),.01)
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE !!,?24,"Originator: ",$SELECT(GMTSSB'="":GMTSSB,1:GMTSSN)
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $LENGTH(GMTSST)
- WRITE !,?24,"Title: ",GMTSST
- +4 QUIT