BMCFDR3 ; IHS/PHXAO/TMJ - DRIVER TO RE-PRINT/EDIT/DELETE SECONDARY PROVIDER LETTER ;
;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
;IHS/ITSC/FCJ CHG VAR NAME AND ADDED VARS TO KILL
;
;This is the Main Driver Routine -
;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER
;Calls PRINT ROUTINE BMCFPRN3
;After User Input of data - RCIS SECONDARY PROVIDER FILE
;is populated with data ^BMCPROV( Global
;
START ;
S BMCCPRV="",BMCAPDT="",BMCAPUR=""
W:$D(IOF) @IOF
W "********** REFERRAL FORM PRINT-SECONDARY PROVIDER **********",!!
W "This option will produce a hard copy computer generated",!,"-Existing Secondary Provider Letter",!
W "You can also edit or delete an existing Secondary Provider Letter.",!!
S BMCQUIT=0
S BMCPROV=""
S BMCCPRV="" ;Secondary Provider Name
S BMCAPPDT="" ;Secondary Provider Appointment Date
S BMCAPUR="" ;Secondary Provider Purpose of Appointment
S BMCKIND=0 ; Determines if Type of Referral=IHS
GETREF ;get referral entry
;
S DIR(0)="S^1:STANDARD;2:AHCCCS",DIR("A")="Enter Secondary Letter Type",DIR("B")="STANDARD",DIR("?")="Enter Letter Form Output Choice" KILL DA D ^DIR KILL DIR
I $D(DIRUT) G XIT
S BMCHOICE=Y
S BMCFTYPE=$S(BMCHOICE=1:5,BMCHOICE=2:7,1:5)
;
W !! S BMCREF=""
S DIC="^BMCPROV(",DIC(0)="AEMQ",DIC("A")="Select Secondary Letter by Patient Name or Date of Letter: " D ^DIC K DA,DIC
G:Y=-1 XIT
S BMCPROV=+Y
Q:'BMCPROV
I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF
S BMCREF=$P($G(^BMCPROV(BMCPROV,0)),U,3)
Q:BMCREF=""
I $P($G(^BMCREF(BMCREF,0)),U,4)="N" W !!,?10,"In-House Reerrals are not allowed with this Menu Option",!! G GETREF
;
GETLTR ;Select the desired Secondary Letter to edit - print - delete
;
;IHS Type
I $P($G(^BMCREF(BMCREF,0)),U,4)="I" D
. S BMCCPRV=$P($G(^BMCPROV(BMCPROV,0)),U,8)
. Q:BMCCPRV=""
. S BMCCPRVP=$P($G(^DIC(4,BMCCPRV,0)),U)
. Q:BMCCPRVP=""
. S BMCKIND=1
;
;CHS or Other Types
I BMCKIND=1 G TYPE
S BMCCPRV=$P($G(^BMCPROV(BMCPROV,0)),U,5) ; GET 2ND PROVIDER
I BMCCPRV="" W !!,?10,"**Secondary Provider Data Missing on Letter**!!" Q
S BMCCPRVP=$P($G(^AUTTVNDR(BMCCPRV,0)),U) ;GET ACTUAL PROVIDER NAME
;
TYPE ;Get Remaining Provider Data
;
S BMCAPPDT=$P($G(^BMCPROV(BMCPROV,0)),U,6) ;GET EXPT APPT DT
S BMCAPUR=$P($G(^BMCPROV(BMCPROV,0)),U,7) ;GET PURPOSE
ZIS ;
W !! S XBRC="COMP^BMCFDR3",XBRP="PRINT^BMCFDR3",XBNS="BMC",XBRX="XIT^BMCFDR3"
D ^XBDBQUE
Q
;
PRINT ;EP
X:$D(^BMCTFORM(BMCFTYPE,12)) ^BMCTFORM(BMCFTYPE,12)
Q
XIT ;
K BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS
K A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z
K BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN
K BMCPROV,BMCAPDT,BMCQUIT,BMCCPRV,BMCCPRVP,BMCAPUR,BMCFTYPE,BMCREF,BMCDT,BMCAPPDT,BMCKIND,BMCHOICE,BMCTYPE
K BMCCMT
Q
COMP ;
Q
WP ;EP - Entry point to print wp fields pass node in BMCWP
;PASS FILE IN BMCFILE, ENTRY IN BMCREF
NEW G,P,BMCX
K BMCWP
K ^UTILITY($J,"W")
S BMCX=0,P=0
S G=$S($G(G)]"":G,1:^DIC(BMCFILE,0,"GL")),G=G_BMCDA_","_BMCNODE_",BMCX)"
S DIWR=$S($G(BMCIOM):BMCIOM,1:IOM),DIWL=0 F S BMCX=$O(@G) Q:BMCX'=+BMCX D
.S Y=$P(G,")")_",0)"
.S X="" I $G(BMCCAP)]"",BMCX=1 S X=BMCCAP
.S X=X_@Y D ^DIWP
WPS ;EP
S Z=0 F S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z S P=P+1,BMCWP(P)=^UTILITY($J,"W",DIWL,Z,0)
K DIWL,DIWR,DIWF,Z
K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP
Q
BMCFDR3 ; IHS/PHXAO/TMJ - DRIVER TO RE-PRINT/EDIT/DELETE SECONDARY PROVIDER LETTER ;
+1 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006
+2 ;IHS/ITSC/FCJ CHG VAR NAME AND ADDED VARS TO KILL
+3 ;
+4 ;This is the Main Driver Routine -
+5 ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER
+6 ;Calls PRINT ROUTINE BMCFPRN3
+7 ;After User Input of data - RCIS SECONDARY PROVIDER FILE
+8 ;is populated with data ^BMCPROV( Global
+9 ;
START ;
+1 SET BMCCPRV=""
SET BMCAPDT=""
SET BMCAPUR=""
+2 IF $DATA(IOF)
WRITE @IOF
+3 WRITE "********** REFERRAL FORM PRINT-SECONDARY PROVIDER **********",!!
+4 WRITE "This option will produce a hard copy computer generated",!,"-Existing Secondary Provider Letter",!
+5 WRITE "You can also edit or delete an existing Secondary Provider Letter.",!!
+6 SET BMCQUIT=0
+7 SET BMCPROV=""
+8 ;Secondary Provider Name
SET BMCCPRV=""
+9 ;Secondary Provider Appointment Date
SET BMCAPPDT=""
+10 ;Secondary Provider Purpose of Appointment
SET BMCAPUR=""
+11 ; Determines if Type of Referral=IHS
SET BMCKIND=0
GETREF ;get referral entry
+1 ;
+2 SET DIR(0)="S^1:STANDARD;2:AHCCCS"
SET DIR("A")="Enter Secondary Letter Type"
SET DIR("B")="STANDARD"
SET DIR("?")="Enter Letter Form Output Choice"
KILL DA
DO ^DIR
KILL DIR
+3 IF $DATA(DIRUT)
GOTO XIT
+4 SET BMCHOICE=Y
+5 SET BMCFTYPE=$SELECT(BMCHOICE=1:5,BMCHOICE=2:7,1:5)
+6 ;
+7 WRITE !!
SET BMCREF=""
+8 SET DIC="^BMCPROV("
SET DIC(0)="AEMQ"
SET DIC("A")="Select Secondary Letter by Patient Name or Date of Letter: "
DO ^DIC
KILL DA,DIC
+9 IF Y=-1
GOTO XIT
+10 SET BMCPROV=+Y
+11 IF 'BMCPROV
QUIT
+12 IF $DATA(^BMCTFORM(BMCFTYPE,11))
XECUTE ^BMCTFORM(BMCFTYPE,11)
IF BMCQUIT
GOTO GETREF
+13 SET BMCREF=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,3)
+14 IF BMCREF=""
QUIT
+15 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,4)="N"
WRITE !!,?10,"In-House Reerrals are not allowed with this Menu Option",!!
GOTO GETREF
+16 ;
GETLTR ;Select the desired Secondary Letter to edit - print - delete
+1 ;
+2 ;IHS Type
+3 IF $PIECE($GET(^BMCREF(BMCREF,0)),U,4)="I"
Begin DoDot:1
+4 SET BMCCPRV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,8)
+5 IF BMCCPRV=""
QUIT
+6 SET BMCCPRVP=$PIECE($GET(^DIC(4,BMCCPRV,0)),U)
+7 IF BMCCPRVP=""
QUIT
+8 SET BMCKIND=1
End DoDot:1
+9 ;
+10 ;CHS or Other Types
+11 IF BMCKIND=1
GOTO TYPE
+12 ; GET 2ND PROVIDER
SET BMCCPRV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,5)
+13 IF BMCCPRV=""
WRITE !!,?10,"**Secondary Provider Data Missing on Letter**!!"
QUIT
+14 ;GET ACTUAL PROVIDER NAME
SET BMCCPRVP=$PIECE($GET(^AUTTVNDR(BMCCPRV,0)),U)
+15 ;
TYPE ;Get Remaining Provider Data
+1 ;
+2 ;GET EXPT APPT DT
SET BMCAPPDT=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,6)
+3 ;GET PURPOSE
SET BMCAPUR=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,7)
ZIS ;
+1 WRITE !!
SET XBRC="COMP^BMCFDR3"
SET XBRP="PRINT^BMCFDR3"
SET XBNS="BMC"
SET XBRX="XIT^BMCFDR3"
+2 DO ^XBDBQUE
+3 QUIT
+4 ;
PRINT ;EP
+1 IF $DATA(^BMCTFORM(BMCFTYPE,12))
XECUTE ^BMCTFORM(BMCFTYPE,12)
+2 QUIT
XIT ;
+1 KILL BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS
+2 KILL A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z
+3 KILL BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN
+4 KILL BMCPROV,BMCAPDT,BMCQUIT,BMCCPRV,BMCCPRVP,BMCAPUR,BMCFTYPE,BMCREF,BMCDT,BMCAPPDT,BMCKIND,BMCHOICE,BMCTYPE
+5 KILL BMCCMT
+6 QUIT
COMP ;
+1 QUIT
WP ;EP - Entry point to print wp fields pass node in BMCWP
+1 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
+2 NEW G,P,BMCX
+3 KILL BMCWP
+4 KILL ^UTILITY($JOB,"W")
+5 SET BMCX=0
SET P=0
+6 SET G=$SELECT($GET(G)]"":G,1:^DIC(BMCFILE,0,"GL"))
SET G=G_BMCDA_","_BMCNODE_",BMCX)"
+7 SET DIWR=$SELECT($GET(BMCIOM):BMCIOM,1:IOM)
SET DIWL=0
FOR
SET BMCX=$ORDER(@G)
IF BMCX'=+BMCX
QUIT
Begin DoDot:1
+8 SET Y=$PIECE(G,")")_",0)"
+9 SET X=""
IF $GET(BMCCAP)]""
IF BMCX=1
SET X=BMCCAP
+10 SET X=X_@Y
DO ^DIWP
End DoDot:1
WPS ;EP
+1 SET Z=0
FOR
SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))
IF Z'=+Z
QUIT
SET P=P+1
SET BMCWP(P)=^UTILITY($JOB,"W",DIWL,Z,0)
+2 KILL DIWL,DIWR,DIWF,Z
+3 KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP
+4 QUIT
