BDP.m

BDP ; IHS/CMI/TMJ - DESG SPECIALTY PROVIDER MGT SYSTEM ; 

 ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88

 ;

 ;

 I '$D(ZTQUEUED) W !!,*7,"NO ENTRY FROM THE TOP OF ^BDP.",!

 S BDPQ=1

 Q

 ;----------

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^BDPFMC

 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 

 Q:$G(XQY0)=""

 I '$D(IORVON) S X="IORVON;IORVOFF" D ENDR^%ZISS

 S X=$P(XQY0,U,2)

 S:X="Designated Specialty Provider Management System" X="MAIN MENU"

 S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF

 ;I X="Designated Specialty Provider Management System" S X="MAIN MENU"

 W @IOF,!,$$CTR("DESIGNATED SPECIALTY PROVIDER MANAGEMENT SYSTEM"),!,$$CTR($$LOC()),!,$$CTR(X),!!

 Q

 ;----------

LOCK(DA) ;EP - Lock the selected Record.

 LOCK +^BDPRECN(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 record.

 LOCK -^BDPRECN(DA):20

 E  W:'$D(ZTQUEUED) *7,!!,"  UNABLE TO UNLOCK RECORD.  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","BDP",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("DESIGNATED SPECIALTY PROVIDER MGT 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="Designated Specialty Provider Management System" X="MAIN MENU"

 S X=$J("",2*$L(IORVON)-1)_IORVON_X_IORVOFF

 W !,$$CTR(X),!

 Q

 ;----------

DEV ; EP - SELECT OUTPUT DEVICE

 S BDPQ=0

 S %ZIS="PQ" D ^%ZIS

 S:POP BDPQ=1

 Q

 ;----------

PAUSE ; EP - PAUSE FOR USER

 W !

 S DIR(0)="EO",DIR("A")="Press ENTER...." D ^DIR K DIR S:$D(DUOUT) DIRUT=1

 W !

 Q

 ;----------

CONF ; EP - CONFIDENTIAL CLIENT DATA HEADER

 W !,$$CTR("*** CONFIDENTIAL PATIENT INFORMATION ***"),!

 Q

 ;----------

 Q Y

BDP       ; IHS/CMI/TMJ - DESG SPECIALTY PROVIDER MGT SYSTEM ; 

 +1       ;;2.0;IHS PCC SUITE;**10**;MAY 14, 2009;Build 88

 +2       ;

 +3       ;

 +4        IF '$DATA(ZTQUEUED)

               WRITE !!,*7,"NO ENTRY FROM THE TOP OF ^BDP.",!

 +5        SET BDPQ=1

 +6        QUIT 

 +7       ;----------

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^BDPFMC

 +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 

 +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="Designated Specialty Provider Management System"

               SET X="MAIN MENU"

 +5        SET X=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_X_IORVOFF

 +6       ;I X="Designated Specialty Provider Management System" S X="MAIN MENU"

 +7        WRITE @IOF,!,$$CTR("DESIGNATED SPECIALTY PROVIDER MANAGEMENT SYSTEM"),!,$$CTR($$LOC()),!,$$CTR(X),!!

 +8        QUIT 

 +9       ;----------

LOCK(DA)  ;EP - Lock the selected Record.

 +1        LOCK +^BDPRECN(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 record.

 +1        LOCK -^BDPRECN(DA):20

 +2       IF '$TEST

               IF '$DATA(ZTQUEUED)

                   WRITE *7,!!,"  UNABLE TO UNLOCK RECORD.  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","BDP",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("DESIGNATED SPECIALTY PROVIDER MGT 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="Designated Specialty Provider Management System"

               SET X="MAIN MENU"

 +11       SET X=$JUSTIFY("",2*$LENGTH(IORVON)-1)_IORVON_X_IORVOFF

 +12       WRITE !,$$CTR(X),!

 +13       QUIT 

 +14      ;----------

DEV       ; EP - SELECT OUTPUT DEVICE

 +1        SET BDPQ=0

 +2        SET %ZIS="PQ"

           DO ^%ZIS

 +3        IF POP

               SET BDPQ=1

 +4        QUIT 

 +5       ;----------

PAUSE     ; EP - PAUSE FOR USER

 +1        WRITE !

 +2        SET DIR(0)="EO"

           SET DIR("A")="Press ENTER...."

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)

               SET DIRUT=1

 +3        WRITE !

 +4        QUIT 

 +5       ;----------

CONF      ; EP - CONFIDENTIAL CLIENT DATA HEADER

 +1        WRITE !,$$CTR("*** CONFIDENTIAL PATIENT INFORMATION ***"),!

 +2        QUIT 

 +3       ;----------

 +4        QUIT Y