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