BRN ; IHS/PHXAO/TMJ - DISCLOSURE SYSTEM ;
;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
;IHS/OIT/LJF 01/24/2008 PATCH 1 Added patch # to logo & removed a line feed
;
;
I '$D(ZTQUEUED) W !!,*7,"NO ENTRY FROM THE TOP OF ^BRN.",!
S BRNQ=1
Q
;----------
;----------
GETR() ;EP - Return Disclosure # from ROI DISCLOSURE record
I '$G(BRNRIEN) Q ""
Q $P($G(^BRNREC(BRNRIEN,0)),U,2)
;----------
REFN() ;EP - Return the next Disclosure number and update control file
LOCK +^BRNPARM(DUZ(2)):20 E W:'$D(ZTQUEUED) *7,!!," Unable to lock the ROI SITE PARAMETER entry for ",$$LOC,".",!! D EOP Q 0
S BRNPARM=$G(^BRNPARM(DUZ(2),0))
S X=$$ASF
S X=X_$P(BRNPARM,U,2)
S Y=$P(BRNPARM,U,7)+1
S X=X_$$LZERO(Y,5)
S BRNX=X
S DIE="^BRNPARM(",DA=DUZ(2),DR=".07////"_Y D DIE^BRNFMC
LOCK -^BRNPARM(DUZ(2)):20
Q BRNX
;----------
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^BRNFMC
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 +^BRNREC(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 -^BRNREC(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","BRN",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))
;
;IHS/OIT/LJF 01/24/2008 PATCH 1
NEW P,PATCH,PDATE S (PATCH,PDATE)=""
S P=$O(^DIC(9.4,I,22,A,"PAH","B",""),-1) I P S PATCH=$P($G(^DIC(9.4,I,22,A,"PAH",P,0)),U),PDATE=$$FMTE^XLFDT($P($G(^(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 @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*"
W !?L,"*",$$CTR("RELEASE OF INFORMATION SYSTEM",N),?R,"*"
W !?L,"*",$$CTR("VERSION "_V_" P"_PATCH_", "_$S(PDATE]"":PDATE,1:Y),N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
;end of PATCH 1 changes
;
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="Release of Information System" X="MAIN MENU"
S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF
;W !,$$CTR(X),!
W !,$$CTR(X) ;IHS/OIT/LJF 01/24/2008 PATCH 1
Q
;----------
SEL(S) ;EP - Select a Disclosure to edit, S is DIC("S")
NEW BRN,BRNY,DA,DIC
S:$D(S) DIC("S")=S
S DIC="^BRNREC(",Y=$$DIC(.DIC)
I Y<1 Q Y
S DA=+Y D LOCK(DA) E Q 0
S BRN=DA
I '$D(ZTQUEUED) D
.S DIC="^BRNREC(" D DIQ^BRNFMC
.S DA=$O(^BRNCOM("AD",BRN,0)) I DA S DIC="^BRNCOM(" D DIQ^BRNFMC
.F BRNY=0:0 S BRNY=$O(^BRNDX("AD",BRN,BRNY)) Q:'BRNY S DA=BRNY,DIC="^BRNDX(" D DIQ^BRNFMC
.F BRNY=0:0 S BRNY=$O(^BRNPX("AD",BRN,BRNY)) Q:'BRNY S DA=BRNY,DIC="^BRNPX(" D DIQ^BRNFMC
.D EOP
.Q
Q BRN
;----------
DEV ; EP - SELECT OUTPUT DEVICE
S BRNQ=0
S %ZIS="PQ" D ^%ZIS
S:POP BRNQ=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(^BRNREC(R,0)) TOFACX
S X=^BRNREC(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(^BRNLPRV(Y,0),U)
TOFACX ;
Q Y
BRN ; IHS/PHXAO/TMJ - DISCLOSURE SYSTEM ;
+1 ;;2.0;RELEASE OF INFO SYSTEM;*1*;APR 10, 2003
+2 ;IHS/OIT/LJF 01/24/2008 PATCH 1 Added patch # to logo & removed a line feed
+3 ;
+4 ;
+5 IF '$DATA(ZTQUEUED)
WRITE !!,*7,"NO ENTRY FROM THE TOP OF ^BRN.",!
+6 SET BRNQ=1
+7 QUIT
+8 ;----------
+9 ;----------
GETR() ;EP - Return Disclosure # from ROI DISCLOSURE record
+1 IF '$GET(BRNRIEN)
QUIT ""
+2 QUIT $PIECE($GET(^BRNREC(BRNRIEN,0)),U,2)
+3 ;----------
REFN() ;EP - Return the next Disclosure number and update control file
+1 LOCK +^BRNPARM(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 BRNPARM=$GET(^BRNPARM(DUZ(2),0))
+3 SET X=$$ASF
+4 SET X=X_$PIECE(BRNPARM,U,2)
+5 SET Y=$PIECE(BRNPARM,U,7)+1
+6 SET X=X_$$LZERO(Y,5)
+7 SET BRNX=X
+8 SET DIE="^BRNPARM("
SET DA=DUZ(2)
SET DR=".07////"_Y
DO DIE^BRNFMC
+9 LOCK -^BRNPARM(DUZ(2)):20
+10 QUIT BRNX
+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^BRNFMC
+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 +^BRNREC(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 -^BRNREC(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","BRN",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 ;
+5 ;IHS/OIT/LJF 01/24/2008 PATCH 1
+6 NEW P,PATCH,PDATE
SET (PATCH,PDATE)=""
+7 SET P=$ORDER(^DIC(9.4,I,22,A,"PAH","B",""),-1)
IF P
SET PATCH=$PIECE($GET(^DIC(9.4,I,22,A,"PAH",P,0)),U)
SET PDATE=$$FMTE^XLFDT($PIECE($GET(^(0)),U,2))
+8 ;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)),!
+9 WRITE @IOF,!,$$CTR($$REPEAT^XLFSTR("*",D)),!?L,"*",$$CTR("INDIAN HEALTH SERVICE",N),?R,"*"
+10 WRITE !?L,"*",$$CTR("RELEASE OF INFORMATION SYSTEM",N),?R,"*"
+11 WRITE !?L,"*",$$CTR("VERSION "_V_" P"_PATCH_", "_$SELECT(PDATE]"":PDATE,1:Y),N),?R,"*",!,$$CTR($$REPEAT^XLFSTR("*",D)),!
+12 ;end of PATCH 1 changes
+13 ;
+14 WRITE $$CTR($$LOC())
+15 ;Sub Menu Displays
+16 IF $GET(XQY0)=""
QUIT
+17 IF '$DATA(IORVON)
SET X="IORVON;IORVOFF"
DO ENDR^%ZISS
+18 SET X=$PIECE(XQY0,U,2)
+19 IF X="Release of Information System"
SET X="MAIN MENU"
+20 SET X=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_X_IORVOFF
+21 ;W !,$$CTR(X),!
+22 ;IHS/OIT/LJF 01/24/2008 PATCH 1
WRITE !,$$CTR(X)
+23 QUIT
+24 ;----------
SEL(S) ;EP - Select a Disclosure to edit, S is DIC("S")
+1 NEW BRN,BRNY,DA,DIC
+2 IF $DATA(S)
SET DIC("S")=S
+3 SET DIC="^BRNREC("
SET Y=$$DIC(.DIC)
+4 IF Y<1
QUIT Y
+5 SET DA=+Y
DO LOCK(DA)
IF '$TEST
QUIT 0
+6 SET BRN=DA
+7 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+8 SET DIC="^BRNREC("
DO DIQ^BRNFMC
+9 SET DA=$ORDER(^BRNCOM("AD",BRN,0))
IF DA
SET DIC="^BRNCOM("
DO DIQ^BRNFMC
+10 FOR BRNY=0:0
SET BRNY=$ORDER(^BRNDX("AD",BRN,BRNY))
IF 'BRNY
QUIT
SET DA=BRNY
SET DIC="^BRNDX("
DO DIQ^BRNFMC
+11 FOR BRNY=0:0
SET BRNY=$ORDER(^BRNPX("AD",BRN,BRNY))
IF 'BRNY
QUIT
SET DA=BRNY
SET DIC="^BRNPX("
DO DIQ^BRNFMC
+12 DO EOP
+13 QUIT
End DoDot:1
+14 QUIT BRN
+15 ;----------
DEV ; EP - SELECT OUTPUT DEVICE
+1 SET BRNQ=0
+2 SET %ZIS="PQ"
DO ^%ZIS
+3 IF POP
SET BRNQ=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(^BRNREC(R,0))
GOTO TOFACX
+7 SET X=^BRNREC(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(^BRNLPRV(Y,0),U)
TOFACX ;
+1 QUIT Y
