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

AZXA.m

Go to the documentation of this file. 
  1. AZXA ; IHS/PHXAO/TMJ - DISCLOSURE SYSTEM ; 
  1.  ;;2.0;RELEASE OF INFORMATION;;FEB 21, 2002
  1.  ;
  1.  ;
  1.  I '$D(ZTQUEUED) W !!,*7,"NO ENTRY FROM THE TOP OF ^AZXA.",!
  1.  S AZXAQ=1
  1.  Q
  1.  ;----------
  1.  ;----------
  1. GETR() ;EP - Return Disclosure # from ROI DISCLOSURE record
  1.  I '$G(AZXARIEN) Q ""
  1.  Q $P($G(^AZXAREC(AZXARIEN,0)),U,2)
  1.  ;----------
  1. REFN() ;EP - Return the next Disclosure number and update control file
  1.  LOCK +^AZXAPARM(DUZ(2)):20 E  W:'$D(ZTQUEUED) *7,!!,"  Unable to lock the ROI SITE PARAMETER entry for ",$$LOC,".",!! D EOP Q 0
  1.  S AZXAPARM=$G(^AZXAPARM(DUZ(2),0))
  1.  S X=$$ASF
  1.  S X=X_$P(AZXAPARM,U,2)
  1.  S Y=$P(AZXAPARM,U,7)+1
  1.  S X=X_$$LZERO(Y,5)
  1.  S AZXAX=X
  1.  S DIE="^AZXAPARM(",DA=DUZ(2),DR=".07////"_Y D DIE^AZXAFMC
  1.  LOCK -^AZXAPARM(DUZ(2)):20
  1.  Q AZXAX
  1.  ;----------
  1. LZERO(V,L) ;left zero fill
  1.  NEW %,I
  1.  S %=$L(V),Z=L-% F I=1:1:Z S V="0"_V
  1.  Q V
  1.  ;----------
  1. ASF() ;EP - Return ASUFAC number for current DUZ(2).
  1.  Q:'$G(DUZ(2)) ""
  1.  Q $P($G(^AUTTLOC(DUZ(2),0)),U,10)
  1.  ;----------
  1. CTR(X,Y) ;EP - Center X in a field Y wide.
  1.  Q $J("",$S($D(Y):Y,1:IOM)-$L(X)\2)_X
  1.  ;----------
  1. DIC(DIC) ;EP - File lookup.
  1.  S:'$D(DIC(0)) DIC(0)="AMQN"
  1.  D DIC^AZXAFMC
  1.  Q +Y
  1.  ;----------
  1. EOP ;EP - End of page.
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  NEW DIR
  1.  K DIRUT,DFOUT,DLOUT,DTOUT,DUOUT
  1.  S DIR(0)="E" D ^DIR
  1.  Q
  1.  ;----------
  1. USR() ;EP - Return name of current user from ^VA(200.
  1.  Q $S($G(DUZ):$S($D(^VA(200,DUZ,0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ UNDEFINED OR 0")
  1.  ;----------
  1. LOC() ;EP - Return location name from file 4 based on DUZ(2).
  1.  Q $S($G(DUZ(2)):$S($D(^DIC(4,DUZ(2),0)):$P(^(0),U),1:"UNKNOWN"),1:"DUZ(2) UNDEFINED OR 0")
  1.  ;----------
  1. HDR ;EP - Screen header DON'S USE ANY LONGER.
  1.  Q:$G(XQY0)=""
  1.  I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
  1.  S X=$P(XQY0,U,2)
  1.  S:X="FOIA Disclosure System" X="MAIN MENU"
  1.  S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF
  1.  ;I X="FOIA Disclosure System" S X="MAIN MENU"
  1.  W @IOF,!,$$CTR("FOIA DISCLOSURE SYSTEM"),!,$$CTR($$LOC()),!,$$CTR(X),!!
  1.  Q
  1.  ;----------
  1. LOCK(DA) ;EP - Lock the selected Disclosure.
  1.  LOCK +^AZXAREC(DA):20
  1.  E  W:'$D(ZTQUEUED) *7,!!,"  This Document Is Currently Being Processed (Document LOCKED).",!! D EOP I 0
  1.  Q
  1.  ;----------
  1. UNLOCK(DA)         ;EP - Unlock the selected Disclosure.
  1.  LOCK -^AZXAREC(DA):20
  1.  E  W:'$D(ZTQUEUED) *7,!!,"  UNABLE TO UNLOCK DISCLOSURE.  NOTIFY PROGRAMMER.",!! D EOP I 0
  1.  Q
  1.  ;----------
  1.  NEW A,D,I,L,N,R,V
  1.  S L=18,R=61,D=R-L+1,N=R-L-1
  1.  S I=$O(^DIC(9.4,"C","AZXA",0)),V=^DIC(9.4,I,"VERSION"),A=$O(^DIC(9.4,I,22,"B",V,0)),Y=$$FMTE^XLFDT($P(^DIC(9.4,I,22,A,0),U,2))
  1.  W @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*",!?L,"*",$$CTR("RELEASE OF INFORMATION SYSTEM",N),?R,"*",!?L,"*",$$CTR("VERSION "_V_", "_Y,N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
  1.  W $$CTR($$LOC())
  1.  ;Sub Menu Displays
  1.  Q:$G(XQY0)=""
  1.  I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS
  1.  S X=$P(XQY0,U,2)
  1.  S:X="Referred Care Information System" X="MAIN MENU"
  1.  S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF
  1.  W !,$$CTR(X),!
  1.  Q
  1.  ;----------
  1. SEL(S) ;EP - Select a Disclosure to edit, S is DIC("S")
  1.  NEW AZXA,AZXAY,DA,DIC
  1.  S:$D(S) DIC("S")=S
  1.  S DIC="^AZXAREC(",Y=$$DIC(.DIC)
  1.  I Y<1 Q Y
  1.  S DA=+Y D LOCK(DA) E  Q 0
  1.  S AZXA=DA
  1.  I '$D(ZTQUEUED) D
  1.  .S DIC="^AZXAREC(" D DIQ^AZXAFMC
  1.  .S DA=$O(^AZXACOM("AD",AZXA,0)) I DA S DIC="^AZXACOM(" D DIQ^AZXAFMC
  1.  .F AZXAY=0:0 S AZXAY=$O(^AZXADX("AD",AZXA,AZXAY)) Q:'AZXAY  S DA=AZXAY,DIC="^AZXADX(" D DIQ^AZXAFMC
  1.  .F AZXAY=0:0 S AZXAY=$O(^AZXAPX("AD",AZXA,AZXAY)) Q:'AZXAY  S DA=AZXAY,DIC="^AZXAPX(" D DIQ^AZXAFMC
  1.  .D EOP
  1.  .Q
  1.  Q AZXA
  1.  ;----------
  1. DEV ; EP - SELECT OUTPUT DEVICE
  1.  S AZXAQ=0
  1.  S %ZIS="PQ" D ^%ZIS
  1.  S:POP AZXAQ=1
  1.  Q
  1.  ;----------
  1. PAUSE ; EP - PAUSE FOR USER
  1.  Q:$E(IOST)'="C"
  1.  Q:$D(ZTQUEUED)!'(IOT="TRM")!$D(IO("S"))
  1.  S DIR(0)="E",DIR("A")="Press any key to continue" D ^DIR K DIR
  1.  W !
  1.  Q
  1.  ;----------
  1. CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER
  1.  W !,$$CTR("*** CONFIDENTIAL PATIENT INFORMATION ***"),!
  1.  Q
  1.  ;----------
  1. TOFAC(R) ; EP - RETURN APPROPRIATE
  1.  ;      'TO PRIMARY VENDOR/TO IHS FACILITY/TO OTHER PROVIDER'
  1.  ; R = ROI DISCLOSURE IEN
  1.  NEW X,Y
  1.  S Y=""
  1.  G:'$G(R) TOFACX
  1.  G:'$D(^AZXAREC(R,0)) TOFACX
  1.  S X=^AZXAREC(R,0)
  1.  S Y=$P(X,U,8) I Y S Y=$P(^DIC(4,Y,0),U) G TOFACX
  1.  S Y=$P(X,U,7) I Y S Y=$P(^AUTTVNDR(Y,0),U)
  1.  I Y="OTHER PROVIDER (NON-CHS)" S Y=$P(X,U,9) I Y S Y=$P(^AZXALPRV(Y,0),U)
  1. TOFACX ;
  1.  Q Y