Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AMHVDSG1

AMHVDSG1.m

Go to the documentation of this file. 
  1. AMHVDSG1  ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;  
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**3,4**;JUN 18, 2010;Build 28
  1.  ;
  1. EN(AMHARRY,AMHR) ;EP
  1.  I $G(AMHARRY)="" S AMHARRY="^TMP(""AMHVDSG"",$J)"
  1.  Q:'$D(AMHR)
  1.  Q:'AMHR
  1.  Q:'$D(^AMHREC(AMHR,0))
  1.  D BUILD
  1.  D XIT
  1.  Q
  1.  ;
  1. SET ;set array
  1.  S AMHCTR=AMHCTR+1
  1.  S @AMHARRY@(AMHCTR,0)=AMHSTR
  1.  S AMHSTR=""
  1.  Q
  1. BUILD ; build array
  1.  K X
  1.  K AMHAR
  1.  S AMHVREC=^AMHREC(AMHR,0)
  1.  S Y=$P(AMHVREC,U,8) D:Y ^AUPNPAT
  1.  S AMHSTR="",AMHCTR=0
  1.  I $P(AMHVREC,U,8) D
  1.  .S AMHH="Patient Name",AMHV=$E($P(^DPT($P(AMHVREC,U,8),0),U),1,20) D BUILD1
  1.  .S AMHH="Chart #" S AMHV="" S:$P(AMHVREC,U,8) AMHV=$S($D(^AUPNPAT($P(AMHVREC,U,8),41,DUZ(2),0)):$P(^(0),U,2),1:"None") D BUILD1
  1.  .S AMHH="Date of Birth" S Y=AUPNDOB D DD^%DT S AMHV=Y D BUILD1
  1.  .S AMHH="Sex",AMHV=AUPNSEX D BUILD1
  1.  .I $P($G(^AMHPATR($P(AMHVREC,U,8),0)),U,9)]"" S AMHH="Patient Flag",AMHV=$P(^AMHPATR($P(AMHVREC,U,8),0),U,9) D BUILD1
  1.  .I $P($G(^AMHPATR($P(AMHVREC,U,8),0)),U,11)]"" S AMHH="Flag Narrative",AMHV=$P(^AMHPATR($P(AMHVREC,U,8),0),U,11) D BUILD1
  1.  .S AMHSTR="" D SET
  1. RECORD ;
  1.  S AMHSTR="=============== BH RECORD FILE ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
  1.  D ENP^XBDIQ1(9002011,AMHR,".01:3100","AMHAR(","E")
  1.  F F=.01,.02,.04,.26,.05,.06,.069,.07,.08,.081,.25,.09,.11,.12,.14,.15,.16,.17,.18,.03,.19,.21,.28,1114 D
  1.  .;S F=0 F  S F=$O(AMHAR(F)) Q:F'=+F  I AMHAR(F)]"" D
  1.  .Q:AMHAR(F)=""
  1.  .S AMHDONE(F)=""
  1.  .I F=.081,$P(^AMHREC(AMHR,0),U,8)="" Q
  1.  .S AMHH=$P(^DD(9002011,F,0),U)
  1.  .S AMHV=AMHAR(F)
  1.  .D BUILD1
  1.  S AMHSTR="EDIT HISTORY: " D SET
  1.  S F=0 F  S F=$O(^AMHREC(AMHR,51,F)) Q:F'=+F  D
  1.  .Q:'$D(^AMHREC(AMHR,51,F,0))
  1.  .Q:$P(^AMHREC(AMHR,51,F,0),U)=""
  1.  .Q:$P(^AMHREC(AMHR,51,F,0),U,2)=""
  1.  .S AMHSTR="  "_$$FMTE^XLFDT($P(^AMHREC(AMHR,51,F,0),U),"1P"),$E(AMHSTR,30)=$P($G(^VA(200,$P(^AMHREC(AMHR,51,F,0),U,2),0)),U) D SET
  1.  S F=0 F  S F=$O(AMHAR(F)) Q:F'=+F  I AMHAR(F)]"",'$D(AMHDONE(F)) D
  1.  .I F=.081,$P(^AMHREC(AMHR,0),U,8)="" Q
  1.  .Q:F=.33  ;I F=.33,$$DATE^AMHESIG()<$P($P(^AMHREC(AMHR,0),U),".") Q
  1.  .Q:F=1108
  1.  .S AMHH=$P(^DD(9002011,F,0),U)
  1.  .S AMHV=AMHAR(F)
  1.  .D BUILD1
  1.  S AMHSTR="" D SET
  1. AXIS3 ;
  1.  I $$DSMCS^AMHUTIL1(DUZ(2),$P($P(^AMHREC(AMHR,0),U),"."))'=4 G TIUN
  1.  S AMHSTR="AXIS III:" D SET
  1.  K AMHAR D ENP^XBDIQ1(9002011,AMHR,5301,"AMHAR(","E")
  1.  S F=0 F  S F=$O(AMHAR(5301,F)) Q:F'=+F  S AMHSTR=AMHAR(5301,F) D SET
  1.  S AMHSTR="" D SET
  1. AXIS4 ;
  1.  S AMHSTR="AXIS IV:" D SET
  1.  K AMHAR S Y=0 F  S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y  D
  1.  .S %=$P(^AMHREC(AMHR,61,Y,0),U),AMHSTR=%_" - "_$P(^AMHTAXIV(%,0),U,2) D SET
  1.  S AMHSTR="" D SET
  1.  ;
  1. TIUN ;
  1.  I '$O(^AMHREC(AMHR,54,0)) G 1
  1.  S AMHSTR="" D SET S AMHSTR="TIU DOCUMENTS" D SET S AMHSTR="-------------" D SET
  1.  S AMHDOC=0 F  S AMHDOC=$O(^AMHREC(AMHR,54,"B",AMHDOC)) Q:AMHDOC'=+AMHDOC  D
  1.  .K AMHTIU,AMHERR
  1.  .K ^TMP("AMHOENPS",$J)
  1.  .D TIUDSP
  1.  .Q
  1.  ;
  1. 1 ;
  1.  I $P($G(^AMHREC(AMHR,11)),U,10) G 4  ;ehr visit no subj/obj per BJ
  1.  S AMHSTR="" D SET
  1.  S AMHSTR="SUBJECTIVE/OBJECTIVE:" D SET
  1.  K AMHAR D ENP^XBDIQ1(9002011,AMHR,3101,"AMHAR(","E")
  1.  S F=0 F  S F=$O(AMHAR(3101,F)) Q:F'=+F  S AMHSTR=AMHAR(3101,F) D SET
  1.  S AMHSTR="" D SET
  1. 4 ;
  1.  S AMHSTR="COMMENT/NEXT APPOINTMENT:" D SET
  1.  K AMHAR D ENP^XBDIQ1(9002011,AMHR,8101,"AMHAR(","E")
  1.  S F=0 F  S F=$O(AMHAR(8101,F)) Q:F'=+F  S AMHSTR=AMHAR(8101,F) D SET
  1.  S AMHSTR="" D SET
  1. NFT ;
  1.  S AMHSTR="NOTE FORWARDED TO:" D SET
  1.  K AMHAR S Y=0 F  S Y=$O(^AMHREC(AMHR,52,Y)) Q:Y'=+Y  D
  1.  .S %=$P(^AMHREC(AMHR,52,Y,0),U),AMHSTR=$P(^VA(200,%,0),U) D SET
  1.  S AMHSTR="" D SET
  1. 2 ;
  1.  S AMHSTR="MEDICATIONS PRESCRIBED:" D SET
  1.  K AMHAR D ENP^XBDIQ1(9002011,AMHR,4101,"AMHAR(","E")
  1.  S F=0 F  S F=$O(AMHAR(4101,F)) Q:F'=+F  S AMHSTR=AMHAR(4101,F) D SET
  1.  S AMHSTR="" D SET
  1. SAN ;
  1.  I $P(^AMHREC(AMHR,0),U,33)="S" D 1^AMHLESA2
  1.  I $P(^AMHREC(AMHR,0),U,33)="U" D SANU^AMHLESA2
  1. INTAKEX ;
  1. VFILES ;set up array of all v file entries
  1.  NEW DA,D0,DIC,DIQ,DR,DI
  1.  S AMHVFLE=9002011 F  S AMHVFLE=$O(^DIC(AMHVFLE)) Q:AMHVFLE>9002011.50!(AMHVFLE'=+AMHVFLE)  D VF2
  1.  D XIT
  1.  Q
  1.  ;
  1. TIUDSP ;
  1.  S AMHSTR="" D SET
  1.  I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q  ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET Q
  1.  ; Extract specified note
  1.  S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
  1.  K @AMHGBL
  1.  D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
  1.  M AMHTIU=^TMP("AMHOENPS",$J,AMHDOC)
  1.  K ^TMP("AMHOENPS",$J)
  1.  S AMHSTR="TIU DOCUMENT:  "_AMHTIU(.01,"E") D SET
  1.  S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D SET
  1.  S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_"               STATUS: "_AMHTIU(.05,"E") D SET
  1.  S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D SET
  1.  F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX  S AMHSTR=AMHTIU("TEXT",AMHX,0) D SET
  1.  I $L($G(AMHTIU(1501,"E"))) D
  1.  .S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D SET
  1.  .S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D SET
  1.  ;NOW GET ADDENDA USING "DAD" XREF
  1.  I $O(^TIU(8925,"DAD",AMHDOC,0)) S AMHSTR="" D SET   ;S AMHSTR="This document has addenda." D SET
  1.  S AMHX1=0 F  S AMHX1=$O(^TIU(8925,"DAD",AMHDOC,AMHX1)) Q:AMHX1'=+AMHX1  D
  1.  .I '+$$CANDO^TIULP(AMHX1,"PRINT RECORD",DUZ) Q  ;S AMHSTR="You do not have security clearance to display the addendum." D SET Q
  1.  .S AMHGBL=$NA(^TMP("AMHOENPS",$J))
  1.  .K @AMHGBL
  1.  .K AMHTIU
  1.  .D EXTRACT^TIULQ(AMHX1,AMHGBL,.AMHERR,".01;.02;.03;.05;.07;.08;1202;1203;1205;1208;1209;1301;1307;1402;1501:1505;1507:1513;1701","",1,"E")
  1.  .M AMHTIU=^TMP("AMHOENPS",$J,AMHX1)
  1.  .K ^TMP("AMHOENPS",$J)
  1.  .S AMHSTR="" D SET
  1.  .S AMHSTR=AMHTIU(.01,"E") D SET
  1.  .S AMHSTR="AUTHOR: "_AMHTIU(1202,"E") D SET
  1.  .S AMHSTR="SIGNED BY: "_AMHTIU(1502,"E")_"               STATUS: "_AMHTIU(.05,"E") D SET
  1.  .S AMHSTR="LOCATION: "_AMHTIU(1205,"E") D SET
  1.  .F AMHX=0:0 S AMHX=$O(AMHTIU("TEXT",AMHX)) Q:'AMHX  S AMHSTR=AMHTIU("TEXT",AMHX,0) D SET
  1.  .I $L($G(AMHTIU(1501,"E"))) D
  1.  ..S AMHSTR="/es/ "_$G(AMHTIU(1503,"E")) D SET
  1.  ..S AMHSTR="Signed: "_$G(AMHTIU(1501,"E")) D SET
  1.  ;
  1.  Q
  1. VF2 ;
  1.  S AMHVNM=$P(^DIC(AMHVFLE,0),U),AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""AD"",AMHR,AMHVDFN)",AMHVDFN=""
  1.  I AMHVFLE=9002011.06 S AMHVNM=$P(^DIC(AMHVFLE,0),U),AMHVDG=^DIC(AMHVFLE,0,"GL"),AMHVIGR=AMHVDG_"""B"",AMHR,AMHVDFN)",AMHVDFN=""
  1.  F AMHVI=1:1 S AMHVDFN=$O(@AMHVIGR) Q:AMHVDFN=""  D VF3
  1.  Q
  1.  ;
  1. VF3 ;
  1.  I AMHVI<2 S AMHSTR="" D SET S AMHSTR="=============== "_AMHVNM_" ===============",X=(80-$L(AMHSTR)\2) D SET ;$J("",X)_AMHSTR D SET
  1.  K AMHAR D ENP^XBDIQ1(AMHVFLE,AMHVDFN,".01:.019999;.04:999999","AMHAR(","E")
  1.  I AMHVI>1 S AMHSTR="" D SET
  1.  S F=0 F  S F=$O(AMHAR(F)) Q:F'=+F  I AMHAR(F)]"" D
  1.  .S AMHH=$P(^DD(AMHVFLE,F,0),U)
  1.  .S AMHV=AMHAR(F)
  1.  .D BUILD1
  1.  Q
  1. BUILD1 ;
  1.  S AMHSTR=$E(AMHH,1,21)_":",AMHSTR=$$SETSTR^VALM1(AMHV,AMHSTR,24,$L(AMHV))
  1.  D SET
  1.  Q
  1.  I $L(AMHSTR)>39 D SET
  1.  S AMHV=" "_AMHV_" ",X=AMHH_": "_AMHV
  1.  I $L(AMHSTR),$L(X)>40 D SET
  1.  I $L(AMHSTR) S AMHSTR=$$SETSTR^VALM1(X,AMHSTR,40,$L(X))
  1.  I '$L(AMHSTR) S AMHSTR=X
  1.  K AMHV,AMHH,X
  1.  Q
  1. XIT ;
  1.  K AMHAR,AMHARRY,AMHCTR,AMHH,AMHSTR,AMHV,AMHVDFN,AMHVDG,AMHVFLE,AMHVI,AMHR,AMHVIGR,AMHFL,AMHVNM,AMHVREC,AMHH
  1.  K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
  1.  Q