BDPPOST ; IHS/CMI/TMJ - Post Init to Populate File ;
;;1.0;DESIGNATED PROVIDER MGT SYSTEM;;SEP 10, 2004
;
;This routine $O's through the Patient File, the MHSS Patient
;File, and the BW Patient File to pick up existing Desg. Providers
;for the new Desg. Provider Mgt System
;
START ;Begin Post Init
S BDPCONV=""
S BDPCONV=$O(^BDPPARM("B",DUZ(2),""))
;Q:BDPCONV=""
;S BDPCONV1=$P($G(^BDPPARM(BDPCONV,0)),U,2) ;Conversion Field
I BDPCONV'="" W !!,"Conversion already ran - Quit ",!! Q ;Converison Check
;
D PCP ;Designated Primary Care Provider
D MH ;Mental Health Primary Care Provider
D SS ;Social Services Primary Care Provider
D CD ;Chemical Dependency Primary Care Provider
D WH ;Womens Health Case Manager
D EOJ
Q
;
PCP ;Populate DPCP
S BDPPROV=0 F S BDPPROV=$O(^AUPNPAT("AK",BDPPROV)) Q:BDPPROV'=+BDPPROV D
.S BDPDFN=0 F S BDPDFN=$O(^AUPNPAT("AK",BDPPROV,BDPDFN)) Q:BDPDFN'=+BDPDFN D
.. Q:'$P(^AUPNPAT(BDPDFN,0),U,14) ;Quit if no Record
.. Q:BDPPROV=""
.. S BDPTYPE=1 ;DPCP Category
.. D ADD ;Populate DPCP
;
Q
;
MH ;Populate MH Provider
S BDPPROV=0 F S BDPPROV=$O(^AMHPATR("AMH",BDPPROV)) Q:BDPPROV'=+BDPPROV D
.S BDPDFN=0 F S BDPDFN=$O(^AMHPATR("AMH",BDPPROV,BDPDFN)) Q:BDPDFN'=+BDPDFN D
.. Q:'$P(^AMHPATR(BDPDFN,0),U,2) ;Quit if no Current Provider
.. Q:BDPPROV=""
.. S BDPTYPE=2 ;DPCP Category
.. D ADD ;Populate MH Provider
;
Q
;
;
SS ;Populate the Social Service Provider
S BDPPROV=0 F S BDPPROV=$O(^AMHPATR("ASS",BDPPROV)) Q:BDPPROV'=+BDPPROV D
.S BDPDFN=0 F S BDPDFN=$O(^AMHPATR("ASS",BDPPROV,BDPDFN)) Q:BDPDFN'=+BDPDFN D
.. Q:'$P(^AMHPATR(BDPDFN,0),U,3) ;Quit if no Current Provider
.. Q:BDPPROV=""
.. S BDPTYPE=3 ;SS Category
.. D ADD ;Populate SS Provider
;
Q
;
;
CD ;Populate the Chemical Dependency Provider
S BDPPROV=0 F S BDPPROV=$O(^AMHPATR("AOT",BDPPROV)) Q:BDPPROV'=+BDPPROV D
.S BDPDFN=0 F S BDPDFN=$O(^AMHPATR("AOT",BDPPROV,BDPDFN)) Q:BDPDFN'=+BDPDFN D
.. Q:'$P(^AMHPATR(BDPDFN,0),U,4) ;Quit if no Current Provider
.. Q:BDPPROV=""
.. S BDPTYPE=4 ;CD Category
.. D ADD ;Populate CD Provider
;
Q
;
WH ;Populate Case Mgr from Women's Health
S BDPPROV=0 F S BDPPROV=$O(^BWP("C",BDPPROV)) Q:BDPPROV'=+BDPPROV D
.S BDPDFN=0 F S BDPDFN=$O(^BWP("C",BDPPROV,BDPDFN)) Q:BDPDFN'=+BDPDFN D
.. Q:'$P(^BWP(BDPDFN,0),U,10) ;Quit if no Current Provider
.. Q:BDPPROV=""
.. S BDPTYPE=8 ;WH Category
.. D ADD ;Populate WOMENS HEALTH Provider
;
Q
;
;
ADD ;Populate the BDP DESG PROV PACKAGE
Q:'$D(BDPDFN)
Q:'$D(BDPTYPE)
Q:'$D(BDPPROV)
;
S X=$$CREATE^BDPPASS(BDPDFN,BDPTYPE,BDPPROV) Q
;
;
EOJ ;End of Job
;
;D ^XBFMK S DIE="^BDPPARM(",DA=DUZ(2),DR=".01///"_DUZ(2);".02///"_1 D ^DIE,XBFMK
D ^XBFMK K DIADD,DINUM
S X=DUZ(2),DIC="^BDPPARM(",DIC(0)="L",DLAYGO=90360.4
S DIC("DR")=".02///"_1
D FILE^DICN D ^XBFMK K DIADD,DINUM
W !!,"Finished adding the MH SS CD WH Case Managers",!,"to the Desg Specialty Provider Package ",!!
K BDPPROV,BDPPAT,BDPTYPE,BDPDFN,BDPCONV,BDPCONV1
Q
BDPPOST ; IHS/CMI/TMJ - Post Init to Populate File ;
+1 ;;1.0;DESIGNATED PROVIDER MGT SYSTEM;;SEP 10, 2004
+2 ;
+3 ;This routine $O's through the Patient File, the MHSS Patient
+4 ;File, and the BW Patient File to pick up existing Desg. Providers
+5 ;for the new Desg. Provider Mgt System
+6 ;
START ;Begin Post Init
+1 SET BDPCONV=""
+2 SET BDPCONV=$ORDER(^BDPPARM("B",DUZ(2),""))
+3 ;Q:BDPCONV=""
+4 ;S BDPCONV1=$P($G(^BDPPARM(BDPCONV,0)),U,2) ;Conversion Field
+5 ;Converison Check
IF BDPCONV'=""
WRITE !!,"Conversion already ran - Quit ",!!
QUIT
+6 ;
+7 ;Designated Primary Care Provider
DO PCP
+8 ;Mental Health Primary Care Provider
DO MH
+9 ;Social Services Primary Care Provider
DO SS
+10 ;Chemical Dependency Primary Care Provider
DO CD
+11 ;Womens Health Case Manager
DO WH
+12 DO EOJ
+13 QUIT
+14 ;
PCP ;Populate DPCP
+1 SET BDPPROV=0
FOR
SET BDPPROV=$ORDER(^AUPNPAT("AK",BDPPROV))
IF BDPPROV'=+BDPPROV
QUIT
Begin DoDot:1
+2 SET BDPDFN=0
FOR
SET BDPDFN=$ORDER(^AUPNPAT("AK",BDPPROV,BDPDFN))
IF BDPDFN'=+BDPDFN
QUIT
Begin DoDot:2
+3 ;Quit if no Record
IF '$PIECE(^AUPNPAT(BDPDFN,0),U,14)
QUIT
+4 IF BDPPROV=""
QUIT
+5 ;DPCP Category
SET BDPTYPE=1
+6 ;Populate DPCP
DO ADD
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
MH ;Populate MH Provider
+1 SET BDPPROV=0
FOR
SET BDPPROV=$ORDER(^AMHPATR("AMH",BDPPROV))
IF BDPPROV'=+BDPPROV
QUIT
Begin DoDot:1
+2 SET BDPDFN=0
FOR
SET BDPDFN=$ORDER(^AMHPATR("AMH",BDPPROV,BDPDFN))
IF BDPDFN'=+BDPDFN
QUIT
Begin DoDot:2
+3 ;Quit if no Current Provider
IF '$PIECE(^AMHPATR(BDPDFN,0),U,2)
QUIT
+4 IF BDPPROV=""
QUIT
+5 ;DPCP Category
SET BDPTYPE=2
+6 ;Populate MH Provider
DO ADD
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
+10 ;
SS ;Populate the Social Service Provider
+1 SET BDPPROV=0
FOR
SET BDPPROV=$ORDER(^AMHPATR("ASS",BDPPROV))
IF BDPPROV'=+BDPPROV
QUIT
Begin DoDot:1
+2 SET BDPDFN=0
FOR
SET BDPDFN=$ORDER(^AMHPATR("ASS",BDPPROV,BDPDFN))
IF BDPDFN'=+BDPDFN
QUIT
Begin DoDot:2
+3 ;Quit if no Current Provider
IF '$PIECE(^AMHPATR(BDPDFN,0),U,3)
QUIT
+4 IF BDPPROV=""
QUIT
+5 ;SS Category
SET BDPTYPE=3
+6 ;Populate SS Provider
DO ADD
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
+10 ;
CD ;Populate the Chemical Dependency Provider
+1 SET BDPPROV=0
FOR
SET BDPPROV=$ORDER(^AMHPATR("AOT",BDPPROV))
IF BDPPROV'=+BDPPROV
QUIT
Begin DoDot:1
+2 SET BDPDFN=0
FOR
SET BDPDFN=$ORDER(^AMHPATR("AOT",BDPPROV,BDPDFN))
IF BDPDFN'=+BDPDFN
QUIT
Begin DoDot:2
+3 ;Quit if no Current Provider
IF '$PIECE(^AMHPATR(BDPDFN,0),U,4)
QUIT
+4 IF BDPPROV=""
QUIT
+5 ;CD Category
SET BDPTYPE=4
+6 ;Populate CD Provider
DO ADD
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
WH ;Populate Case Mgr from Women's Health
+1 SET BDPPROV=0
FOR
SET BDPPROV=$ORDER(^BWP("C",BDPPROV))
IF BDPPROV'=+BDPPROV
QUIT
Begin DoDot:1
+2 SET BDPDFN=0
FOR
SET BDPDFN=$ORDER(^BWP("C",BDPPROV,BDPDFN))
IF BDPDFN'=+BDPDFN
QUIT
Begin DoDot:2
+3 ;Quit if no Current Provider
IF '$PIECE(^BWP(BDPDFN,0),U,10)
QUIT
+4 IF BDPPROV=""
QUIT
+5 ;WH Category
SET BDPTYPE=8
+6 ;Populate WOMENS HEALTH Provider
DO ADD
End DoDot:2
End DoDot:1
+7 ;
+8 QUIT
+9 ;
+10 ;
ADD ;Populate the BDP DESG PROV PACKAGE
+1 IF '$DATA(BDPDFN)
QUIT
+2 IF '$DATA(BDPTYPE)
QUIT
+3 IF '$DATA(BDPPROV)
QUIT
+4 ;
+5 SET X=$$CREATE^BDPPASS(BDPDFN,BDPTYPE,BDPPROV)
QUIT
+6 ;
+7 ;
EOJ ;End of Job
+1 ;
+2 ;D ^XBFMK S DIE="^BDPPARM(",DA=DUZ(2),DR=".01///"_DUZ(2);".02///"_1 D ^DIE,XBFMK
+3 DO ^XBFMK
KILL DIADD,DINUM
+4 SET X=DUZ(2)
SET DIC="^BDPPARM("
SET DIC(0)="L"
SET DLAYGO=90360.4
+5 SET DIC("DR")=".02///"_1
+6 DO FILE^DICN
DO ^XBFMK
KILL DIADD,DINUM
+7 WRITE !!,"Finished adding the MH SS CD WH Case Managers",!,"to the Desg Specialty Provider Package ",!!
+8 KILL BDPPROV,BDPPAT,BDPTYPE,BDPDFN,BDPCONV,BDPCONV1
+9 QUIT
