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

AMHLEFPP.m

Go to the documentation of this file. 
  1. AMHLEFPP ; IHS/CMI/LAB - MENTAL HLTH ROUTINE ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;**5**;JUN 02, 2010;Build 18
  1.  ;
  1.  ;CMI/TUCSON/LAB - added setting of % variable 9/22/97
  1.  ;
  1.  I AMHEFT="B" S AMHEFT="S" D PRINT1 Q:AMHQUIT  S AMHEFT="F" D PRINT1 K AMHEFT Q
  1.  I AMHEFT="T" S AMHEFT="S" D PRINT1 Q:AMHQUIT  S AMHEFT="S" D PRINT1 K AMHEFT Q
  1.  I AMHEFT="E" S AMHEFT="F" D PRINT1 Q:AMHQUIT  S AMHEFT="F" D PRINT1 K AMEFT Q
  1. PRINT1 ;EP - CALLED FROM LAST VISIT DISPLAY
  1.  S AMHR0=^AMHREC(AMHR,0)
  1.  S AMHQUIT=0 I $E(IOST,1,2)'="P-" W:$D(IOF) @IOF
  1.  W !!?13,"********** CONFIDENTIAL PATIENT INFORMATION **********"
  1.  W !?15,"PCC BEHAVIORAL HEALTH ENCOUNTER RECORD"
  1.  W !?18,"***  Computer Generated Encounter Record  ***"
  1.  W !!,$TR($J("",80)," ","*")
  1.  I $Y>(IOSL-5) D FF Q:AMHQUIT
  1.  W !!?3,"Date:  " S Y=$P($P(AMHR0,U),".") D DD^%DT W Y
  1.  W ?31,"Primary Provider: ",$$PPNAME^AMHUTIL(AMHR)
  1.  S AMHX=0 F  S AMHX=$O(^AMHRPROV("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  I $P(^AMHRPROV(AMHX,0),U,4)'="P" W !?35,$P(^VA(200,$P(^AMHRPROV(AMHX,0),U),0),U)
  1.  I $Y>(IOSL-5) D FF Q:AMHQUIT
  1. TIME W !?3,"Arrival Time:  " S Y=$P(AMHR0,U) D DD^%DT W $P(Y,"@",2) I $P(AMHR0,U,27)]"" W ?31,"Flag:  ",$P(AMHR0,U,27)
  1.  W !?3,"Program:  ",$$EXTSET^XBFUNC(9002011,.02,$P(AMHR0,U,2))
  1.  W !?3,"Clinic:  " I $P(AMHR0,U,25) W $P(^DIC(40.7,$P(AMHR0,U,25),0),U)
  1.  W !?3,"Appointment Type:  ",$$EXTSET^XBFUNC(9002011,.11,$P(AMHR0,U,11))
  1.  W !,$TR($J("",80)," ","_")
  1. COMM ;
  1.  I $Y>(IOSL-7) D FF Q:AMHQUIT
  1.  W !?53,"Number",?64,"Activity/Service"
  1.  W !?3,"Community: " W:$P(AMHR0,U,5) $E($P(^AUTTCOM($P(AMHR0,U,5),0),U),1,15)
  1.  W ?32,"Activity:  " I $P(AMHR0,U,6) W $P(^AMHTACT($P(AMHR0,U,6),0),U),"-",$P(^AMHTACT($P(AMHR0,U,6),0),U,8)
  1.  W ?53,"Served: ",$P(AMHR0,U,9),?64,"Time: ",$P(AMHR0,U,12)
  1.  W !?32,"Type of Contact:   " I $P(AMHR0,U,7) W $P(^AMHTSET($P(AMHR0,U,7),0),U)
  1.  W !,$TR($J("",80)," ","_")
  1.  I $Y>(IOSL-4) D FF Q:AMHQUIT
  1.  W !?3,"CHIEF COMPLAINT:  " I AMHEFT="F" S AMHTICL=18,AMHTNRQ=$G(^AMHREC(AMHR,21)),AMHTTXT="" D PRTTXT
  1.  I AMHEFT="S" W !?3,"Chief Complaint/Presenting Problem Suppressed for Confidentiality",!
  1. SUB W !?3,"SUBJECTIVE/OBJECTIVE:  ",!
  1.  I AMHEFT="F" S AMHX=0 F  S AMHX=$O(^AMHREC(AMHR,31,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  .I $Y>(IOSL-6) D FF Q:AMHQUIT
  1.  .W !?4,^AMHREC(AMHR,31,AMHX,0)
  1.  .Q
  1.  I AMHEFT="S" W ?3,"Mental Health or Social Services Contact",!?3,"See ",$$PPNAME^AMHUTIL(AMHR)," for details.",!
  1.  I $Y>(IOSL-5) D FF Q:AMHQUIT
  1.  I $D(^AMHREC(AMHR,61))!($P(AMHR0,U,14)]"") D  Q:AMHQUIT
  1.  .I $Y>(IOSL-5) D FF Q:AMHQUIT
  1.  .W !,$TR($J("",80)," ","_")
  1.  .W !?3,"AXIS IV:  " S Y=0 F  S Y=$O(^AMHREC(AMHR,61,Y)) Q:Y'=+Y  S I=$P(^AMHREC(AMHR,61,Y,0),U) W ?14,$P(^AMHTAXIV(I,0),U)_" - "_$P(^AMHTAXIV(I,0),U,2),!
  1.  .W ?3,"AXIS V:  ",$P(AMHR0,U,14)
  1.  .Q
  1.  W !,$TR($J("",80)," ","_")
  1.  W !?3,"BH POV CODE      PURPOSE OF VISIT (POV)",!?3,"OR DSM DIAGNOSIS    [PRIMARY ON FIRST LINE]"
  1.  W !,$TR($J("",80)," ","_")
  1. POV ;
  1.  S (AMHX,AMHC)=0 F  S AMHX=$O(^AMHRPRO("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  .I $Y>(IOSL-3) D FF Q:AMHQUIT
  1.  .W !?8,$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U)
  1.  .S AMHTNRQ=$S(AMHEFT="F":$P(^AMHPROB($P(^AMHRPRO(AMHX,0),U),0),U,2),1:""),AMHTICL=23,AMHTTXT="" D PRTTXT
  1.  .S AMHTNRQ=$$GET1^DIQ(9002011.01,AMHX,.04),AMHTICL=23,AMHTTXT="" D PRTTXT
  1.  .S AMHC=AMHC+2
  1.  .Q
  1.  Q:AMHQUIT
  1.  F I=AMHC:1:3 D:$Y>(IOSL-3) FF Q:AMHQUIT  W !
  1.  D:$Y>(IOSL-3) FF Q:AMHQUIT  W !,$TR($J("",80)," ","_")
  1. INPT ;
  1.  I $P(AMHR0,U,17)]"" D  Q:AMHQUIT
  1.  .I $Y>(IOSL-4) D FF Q:AMHQUIT
  1.  .W ?3,"Inpatient Disposition: ",$$VAL^XBDIQ1(9002011,AMHR,.17),!?3,"Facility:  ",$P(AMHR0,U,18)
  1.  .W !,$TR($J("",80)," ","_")
  1.  .Q
  1. TMP ;treated med problems
  1.  W !?3,"TREATED MEDICAL PROBLEMS:"
  1.  S (AMHX,AMHC)=0 F  S AMHX=$O(^AMHRTMDP("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  .I $Y>(IOSL-3) D FF Q:AMHQUIT
  1.  .W !?8,$P(^AUTNPOV($P(^AMHRTMDP(AMHX,0),U),0),U)
  1.  .Q
  1.  W !,$TR($J("",80)," ","_")
  1. MEDS ;
  1.  W !?3,"MEDICATIONS PRESCRIBED:"
  1.  S AMHX=0 F  S AMHX=$O(^AMHREC(AMHR,41,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  .I $Y>(IOSL-3) D FF Q:AMHQUIT
  1.  .W !?4,^AMHREC(AMHR,41,AMHX,0)
  1.  .Q
  1.  W !,$TR($J("",80)," ","_")
  1. PROC ;
  1.  W !?3,"PROCEDURES (CPT):"
  1.  S (AMHX,AMHC)=0 F  S AMHX=$O(^AMHRPROC("AD",AMHR,AMHX)) Q:AMHX'=+AMHX!(AMHQUIT)  D
  1.  .I $Y>(IOSL-3) D FF Q:AMHQUIT
  1.  .;W !?8,$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U),"  ",$P(^ICPT($P(^AMHRPROC(AMHX,0),U),0),U,2)
  1.  .W !?8,$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,2)_"  "_$P($$CPT^ICPTCOD($P(^AMHRPROC(AMHX,0),U),$P($P(^AMHREC(AMHR,0),U),".")),U,3)
  1.  .Q
  1. COMMENT ;
  1.  W !,$TR($J("",80)," ","_")
  1.  I $Y>(IOSL-4) D FF Q:AMHQUIT
  1.  S %="" W !?3,"COMMENT:",! ;CMI/TUCSON/LAB - added setting of % 09/22/97
  1.  I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)'="N" S %=0
  1.  I AMHEFT="F" S %=1
  1.  I AMHEFT="S",$P($G(^AMHSITE(DUZ(2),0)),U,27)="N" S %=1
  1.  I '% W !
  1.  I % D
  1.  .S AMHTICL=4,AMHTNRQ=$G(^AMHREC(AMHR,12)),AMHTTXT=""
  1.  .I AMHTNRQ]"" D PRTTXT
  1.  W !,$TR($J("",80)," ","_")
  1. DEMO ;EP demographics
  1.  D DEMO^AMHLEFP1
  1.  Q
  1. PRTTXT ; GENERALIZED TEXT PRINTER
  1.  S AMHTDLT=1,AMHTILN=80-AMHTICL-1
  1.  F AMHTQ=0:0 S:AMHTNRQ]""&(($L(AMHTNRQ)+$L(AMHTTXT)+2)<255) AMHTTXT=$S(AMHTTXT]"":AMHTTXT_"; ",1:"")_AMHTNRQ,AMHTNRQ="" Q:AMHTTXT=""  D PRTTXT2
  1.  K AMHTILN,AMHTDLT,AMHTF,AMHTC,AMHTTXT,AMHTDOO
  1.  Q
  1. PRTTXT2 D GETFRAG W ?AMHTICL W AMHTF,! S AMHTICL=AMHTICL+AMHTDLT,AMHTILN=AMHTILN-AMHTDLT,AMHTDLT=0
  1.  Q
  1. GETFRAG I $L(AMHTTXT)<AMHTILN S AMHTF=AMHTTXT,AMHTTXT="" Q
  1.  F AMHTC=AMHTILN:-1:1 Q:$E(AMHTTXT,AMHTC)=" "
  1.  S AMHTF=$E(AMHTTXT,1,AMHTC-1),AMHTTXT=$E(AMHTTXT,AMHTC+1,255)
  1.  Q
  1.  ;
  1. FF ;EP
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S AMHQUIT=1 Q
  1.  I $E(IOST)'="C" Q:'$P(AMHR0,U,8)  W !!,$TR($J(" ",79)," ","*"),!,$P(^DPT($P(AMHR0,U,8),0),U),?32,"HRN: " D
  1.  .S AMHHRN=$P($G(^AUPNPAT($P(AMHR0,U,8),41,DUZ(2),0)),U,2)
  1.  .W AMHHRN,?46,"DOB: ",$$FMTE^XLFDT($P(^DPT($P(AMHR0,U,8),0),U,3),"2D"),?59,"SSN: ",$$SSN^AMHUTIL($P(AMHR0,U,8)),!
  1.  W:$D(IOF) @IOF
  1.  Q