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

AMHLCD.m

Go to the documentation of this file. 
  1. AMHLCD ; IHS/CMI/LAB - NO DESCRIPTION PROVIDED 16-JAN-1997 ;
  1.  ;;4.0;IHS BEHAVIORAL HEALTH;;MAY 14, 2010
  1.  ;; ;
  1.  ;
  1. EP1(DFN) ;EP - CALLED FROM PROTOCOL
  1.  Q:'$G(DFN)
  1.  Q:'$D(^DPT(DFN))
  1.  Q:$P(^DPT(DFN,0),U,19)
  1.  D EN
  1.  D FULL^VALM1
  1.  K VALMHDR
  1.  Q
  1. EP ;EP CALLED FROM DATA ENTRY
  1.  Q:'$G(AMHPAT)
  1.  S DFN=AMHPAT
  1.  S Y=AMHPAT D ^AUPNPAT
  1.  D EN
  1.  Q
  1. START ;update case data
  1.  K AMHCASE,AMHX
  1.  W:$D(IOF) @IOF W !!,"***  Update Patient Case Data   ***",!!
  1.  S DFN="" F  D GETPAT Q:DFN=""  D EN,FULL^VALM1,EXIT
  1.  D EOJ
  1.  Q
  1. EN ; -- main entry point for AMH UPDATE PATIENT CASE DATA
  1.  D EN^VALM("AMH UPDATE PATIENT CASE DATA")
  1.  K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
  1.  Q
  1.  ;
  1. HDR ; -- header code
  1.  S VALMHDR(1)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(2)="Patient Name: "_$E($P(^DPT(DFN,0),U),1,24)_"   DOB: "_$$DATE($P(^DPT(DFN,0),U,3))_"   Sex: "_$P(^DPT(DFN,0),U,2)_"   HRN: "_$S($D(^AUPNPAT(DFN,41,DUZ(2),0)):$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),1:"??????")
  1.  S VALMHDR(3)=$TR($J(" ",80)," ","-")
  1.  S VALMHDR(4)=""
  1.  S VALMHDR(5)="#   PROGRAM  OPEN      ADMIT     CLOSED   DISPOSITION           PROVIDER"
  1.  Q
  1.  ;
  1. GETPAT ;
  1.  S DFN=""
  1.  W:$D(IOF) @IOF
  1.  W !!!!!!!!?20,"TYPE THE PATIENT'S HRN, NAME, SSN OR DOB" S DIC("A")="                    Patient:  "
  1.  S DFN=""
  1.  S DIC="^AUPNPAT(",DIC(0)="AEMQ" D ^DIC K DIC
  1.  I Y<0 Q
  1.  S DFN=+Y
  1.  I $G(AUPNDOD)]"" W !!?10,"***** PATIENT'S DATE OF DEATH IS ",$$FMTE^XLFDT(AUPNDOD),!! H 2
  1.  Q
  1. INIT ; -- init variables and list array
  1.  S VALMSG="?? for more actions  + next screen  - prev screen"
  1.  D GATHER ;gather up all records for display
  1.  S VALMCNT=AMHLINE
  1.  Q
  1.  ;
  1. GATHER ;
  1.  S AMHRCNT=0,AMHLINE=0
  1.  S AMHD=0 F  S AMHD=$O(^AMHPCASE("AA",DFN,AMHD)) Q:AMHD'=+AMHD  D
  1.  .S AMHX=0 F  S AMHX=$O(^AMHPCASE("AA",DFN,AMHD,AMHX)) Q:AMHX'=+AMHX  D
  1.  ..Q:'$$ALLOWCD(DUZ,AMHX)  ;DON'T ALLOW VIEWING OF CASES NOT BY THIS PROVIDER IS NOT IN SDE
  1.  ..S AMHRCNT=AMHRCNT+1,AMHLINE=AMHLINE+1,%=^AMHPCASE(AMHX,0),Y=AMHRCNT
  1.  ..S $E(Y,5)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.03),1,6),$E(Y,14)=$$FMTE^XLFDT($P(%,U),"2E"),$E(Y,24)=$$FMTE^XLFDT($P(%,U,4),"2E"),$E(Y,34)=$$FMTE^XLFDT($P(%,U,5),"2E")
  1.  ..S $E(Y,43)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.06),1,20),$E(Y,65)=$E($$VAL^XBDIQ1(9002011.58,AMHX,.08),1,15)
  1.  ..S AMHCASE(AMHLINE,0)=Y,AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
  1.  ..I $$VAL^XBDIQ1(9002011.58,AMHX,1101)]"" S AMHLINE=AMHLINE+1,AMHCASE(AMHLINE,0)="    COMMENT: "_$E($$VAL^XBDIQ1(9002011.58,AMHX,1101),1,58)_" **",AMHCASE("IDX",AMHLINE,AMHRCNT)=AMHX
  1.  ..I $P(%,U,9)]""!($P(%,U,12)]"") S AMHLINE=AMHLINE+1 D
  1.  ...S AMHCASE(AMHLINE,0)="    Primary Problem: "_$S($P(%,U,9)]"":$P(^AMHPROB($P(%,U,9),0),U)_" "_$E($P(^AMHPROB($P(%,U,9),0),U,2),1,200),1:"")
  1.  ...S AMHCASE("IDX",AMHLINE,AMHRCNT)=""
  1.  ...S AMHLINE=AMHLINE+1
  1.  ...S AMHCASE(AMHLINE,0)="    Next Review: "_$$FMTE^XLFDT($P(%,U,12),"2E"),AMHCASE("IDX",AMHLINE,AMHRCNT)=""
  1.  Q
  1. ALLOWCD(S,R) ;EP - CAN THIS USER SEE THIS CASE FORM?
  1.  ;S is duz, R is CASE ien
  1.  I '$G(S) Q 0
  1.  I '$G(R) Q 0
  1.  I '$D(^AMHPCASE(R,0)) Q 0
  1.  NEW P
  1.  S P=$P($G(^AMHPCASE(R,0)),U,8)
  1.  ;I 'P Q 0
  1.  I $G(P)="" Q 1
  1.  I $D(^AMHSITE(DUZ(2),16,S)) Q 1  ;$$ALLOWP^AMHUTIL(S,P)  ;allow all with access
  1.  I $P(^AMHPCASE(R,0),U,8)=S Q 1  ;$$ALLOWP^AMHUTIL(S,P)   ;allow your own
  1.  Q 0
  1.  ;I $D(^AMHSITE(DUZ(2),16,DUZ)) Q 1  ;allow all with access
  1.  ;I $P(^AMHPCASE(R,0),U,8)=DUZ Q 1
  1.  ;Q 0
  1. GETDATE ;
  1.  W !!
  1.  S AMHCDATE="",DIR(0)="DO^:"_DT_":EPTX",DIR("A")="Enter CASE OPEN DATE" D ^DIR K DIR S:$D(DUOUT) DIRUT=1
  1.  Q:$D(DIRUT)
  1.  S AMHCDATE=Y
  1.  Q
  1. OPEN ;EP called from protocol to open a new case
  1.  D FULL^VALM1
  1.  W:$D(IOF) @IOF
  1.  W !!!!,"Opening a Case for ",$P(^DPT(DFN,0),U),!!
  1.  D GETDATE
  1.  Q:AMHCDATE=""
  1.  W !,"Creating new case..." K DD,D0,DO,DINUM,DIC,DA,DR S DIC(0)="EL",DIC="^AMHPCASE(",DLAYGO=9002011.58,DIADD=1,X=AMHCDATE,DIC("DR")=".02////"_DFN_";.11///^S X=DT"
  1.  D FILE^DICN K DIC,DR,DIE,DIADD,DLAYGO,X,D0
  1.  I Y=-1 W !!,$C(7),$C(7),"Behavioral Health Case Record failed !!  Deleting Record.",! D PAUSE^AMHLEA Q
  1.  S AMHPC=+Y
  1.  S DA=AMHPC,DDSFILE=9002011.58,DR="[AMH UPDATE CASE]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
  1.  ;CHECK RECORD
  1.  D DP
  1.  D EXIT
  1.  Q
  1. EDIT ;
  1.  S AMHPC=0
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." G EXIT
  1.  S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  S (X,Y)=0 F  S X=$O(AMHCASE("IDX",X)) Q:X'=+X!(AMHPC)  I $O(AMHCASE("IDX",X,0))=AMHR1 S Y=$O(AMHCASE("IDX",X,0)),AMHPC=AMHCASE("IDX",X,Y)
  1.  I '$D(^AMHPCASE(AMHPC,0)) W !,"Not a valid BH CASE RECORD." K AMHR D PAUSE^AMHLEA D EXIT Q
  1.  D FULL^VALM1
  1.  S DA=AMHPC,DDSFILE=9002011.58,DR="[AMH UPDATE CASE]" D ^DDS
  1.  I $D(DIMSG) W !!,"ERROR IN SCREENMAN FORM!!  ***NOTIFY PROGRAMMER***" S AMHQUIT=1 K DIMSG Q
  1.  ;CHECK RECORD
  1.  I '$D(^AMHPCASE(AMHPC,0)) D EXIT Q
  1.  D DP
  1.  D EXIT
  1.  Q
  1. DP ;
  1.  ;if provider on the case data or DUZ matches any designated
  1.  ;provider, then delete that designated provider when case
  1.  ;is closed
  1.  Q:'$G(DA)
  1.  Q:'$D(^AMHPCASE(DA,0))
  1.  Q:$P(^AMHPCASE(DA,0),U,5)=""  ;case not closed
  1.  Q:'$D(^AMHPATR(DFN,0))  ;not patient data (designated provs)
  1.  NEW AMHA,AMHB
  1.  S AMHA=$P(^AMHPCASE(DA,0),U,8)
  1.  K DIE,DA,DR
  1.  I $P(^AMHPATR(DFN,0),U,2)=DUZ S DA=DFN,DR=".02///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,2)=AMHA S DA=DFN,DR=".02///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,3)=DUZ S DA=DFN,DR=".03///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,3)=AMHA S DA=DFN,DR=".03///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,4)=DUZ S DA=DFN,DR=".04///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,4)=AMHA S DA=DFN,DR=".04///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,12)=AMHA S DA=DFN,DR=".12///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  I $P(^AMHPATR(DFN,0),U,12)=DUZ S DA=DFN,DR=".12///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  ;I $P(^AMHPATR(DFN,0),U,13)=AMHA S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  ;I $P(^AMHPATR(DFN,0),U,13)=DUZ S DA=DFN,DR=".13///@",DIE="^AMHPATR(" D ^DIE K DA,DIE,DR
  1.  Q
  1. HELP ; -- help code
  1.  S X="?" D DISP^XQORM1 W !!
  1.  Q
  1.  ;
  1. EXIT ; -- exit code
  1.  K AMHX,AMHCASE,AMHPC,AMHR1
  1.  D TERM^VALM0
  1.  S VALMBCK="R"
  1.  D GATHER
  1.  S VALMCNT=AMHLINE
  1.  D HDR
  1.  K X,Y,Z,I
  1.  Q
  1. EOJ ;
  1.  K DDSFILE,DIPGM,Y
  1.  K X,Y,%,DR,DDS,DA,DIC
  1.  K AMHCASE,AMHX,AMHD,AMHRCNT,AMHLINE,AMHCDATE
  1.  D:$D(VALMWD) CLEAR^VALM1
  1.  K VALM,VALMHDR,VALMKEY,VALMMENU,VALMSGR,VALMUP,VALMWD,VALMLST,VALMVAR,VALMLFT,VALMBCK,VALMCC,VALMAR,VALMBG,VALMCAP,VALMCOFF,VALMCNT,VALMCON,BALMON,VALMEVL,VALMIOXY
  1.  D KILL^AUPNPAT
  1.  Q
  1. DATE(D) ;
  1.  Q $E(D,4,5)_"/"_$E(D,6,7)_"/"_($E(D,1,3)+1700)
  1.  ;
  1. EXPND ; -- expand code
  1.  Q
  1.  ;
  1. DEL ;EP - called from protocol entry
  1.  D FULL^VALM1
  1.  I '$D(^XUSEC("AMHZ DELETE RECORD",DUZ)) W !!,"You do not have the security access to delete a Case.",!,"Please see your supervisor or program manager.",! D PAUSE^AMHLEA,EXIT Q
  1.  S AMHPC=0
  1.  D EN^VALM2(XQORNOD(0),"OS")
  1.  I '$D(VALMY) W !,"No records selected." G EXIT
  1.  S AMHR1=$O(VALMY(0)) I 'AMHR1 K AMHR1,VALMY,XQORNOD W !,"No record selected." G EXIT
  1.  S (X,Y)=0 F  S X=$O(AMHCASE("IDX",X)) Q:X'=+X!(AMHPC)  I $O(AMHCASE("IDX",X,0))=AMHR1 S Y=$O(AMHCASE("IDX",X,0)),AMHPC=AMHCASE("IDX",X,Y)
  1.  I '$D(^AMHPCASE(AMHPC,0)) W !,"Not a valid BH CASE RECORD." K AMHR D PAUSE^AMHLEA D EXIT Q
  1.  D FULL^VALM1
  1.  ;are you sure??
  1.  S DIR(0)="Y",DIR("A")="Are you sure you want to delete this CASE",DIR("B")="N" KILL DA D ^DIR KILL DIR
  1.  I 'Y W !!,"Case not deleted." D PAUSE^AMHLEA,EXIT Q
  1.  S DA=AMHPC,DIK="^AMHPCASE(" D ^DIK
  1.  K DA,DIK
  1.  ;
  1.  D EXIT
  1.  Q