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

AMHGBDSP.m

Go to the documentation of this file. 
  1. AMHGBDSP  ; IHS/CMI/LAB -VISIT DISPLAY NO REVERSE VIDEO FOR GUI ;  
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  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:.33;1401:1701;","AMHAR(","E")
  1.  S F=0 F  S F=$O(AMHAR(F)) Q:F'=+F  I AMHAR(F)]"" D
  1.  .S AMHH=$P(^DD(9002011,F,0),U)
  1.  .S AMHV=AMHAR(F)
  1.  .D BUILD1
  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. TIUN ;
  1.  ;I '$P($G(^AMHREC(AMHR,11)),U,8) G 1
  1.  ;S AMHDOC=$P(^AMHREC(AMHR,11),U,8)
  1.  ;K AMHTIU,AMHERRR
  1.  ;I '+$$CANDO^TIULP(AMHDOC,"PRINT RECORD",DUZ) Q  ;S AMHSTR="You do not have security clearance to display the TIU NOTE." D SET G 1
  1.  ; Extract specified note
  1.  ;S AMHGBL=$NA(^TMP("AMHOENPS",$J)),AMHHLF=IOM\2
  1.  ;K @AMHGBL
  1.  ;D EXTRACT^TIULQ(AMHDOC,AMHGBL,.AMHERRR,".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=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.  ;
  1. 1 ;
  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. INTAKE ;
  1.  G VFILES
  1.  Q
  1.  I $P(^AMHREC(AMHR,0),U,33)="I"!($P(^AMHREC(AMHR,0),U,33)="P") D
  1.  .S AMHSTR="--------------Intake Data Items-------------" D SET
  1.  .S AMHSTR="",AMHH=$P(^DD(9002011.07,.07,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.07) D BUILD1
  1.  .S AMHSTR="",AMHH=$P(^DD(9002011.07,.03,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.03) D BUILD1
  1.  .S AMHSTR="",AMHH=$P(^DD(9002011.07,.02,0),U),AMHV=$$VAL^XBDIQ1(9002011.07,DFN,.02) D BUILD1
  1.  .S AMHSTR="" D SET
  1.  .F AMHX=1000,4100 D
  1.  ..S AMHSTR=$P(^DD(9002011.07,AMHX,0),U)_":" D SET
  1.  ..K AMHAR D ENP^XBDIQ1(9002011.07,DFN,AMHX,"AMHAR(","E")
  1.  ..S F=0 F  S F=$O(AMHAR(AMHX,F)) Q:F'=+F  S AMHSTR=AMHAR(AMHX,F) D SET
  1.  ..S AMHSTR="" D SET
  1.  ..Q
  1. VFILES ;set up array of all v file entries
  1.  NEW DA,D0,DIC,DIQ,DR,DI
  1.  F AMHVFLE=9002011.05,9002011.08 D VF2
  1.  D XIT
  1.  Q
  1.  ;
  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,AMHV,AMHVI
  1.  K DO,D0,DA,DI,DIC,DIQ,DR,F,X,Y,Z
  1.  Q