PSUMAPR ;BHM/PDW-REPORT OF MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003
;;4.0;PHARMACY BENEFITS MANAGEMENT;**7,9**;MARCH, 2005;Build 6
;
;DBIA's
; Reference to file (#58.1) supported by DBIA 2515
; Reference to file (#58.8) supported by DBIA 2519
; Reference to file (#59.7) supported by DBIA 2854
;
EN ; select Editing or Report of Mapping
N C
K PG,LINE,LINE2
S PSQUIT=0,HDR="",$P(LINE,"=",79)="",$P(LINE2,"-",15)=""
D PGH
AOU S HDR="AR/WS AOU" D PGH1
S C=0
S PSNM="" F S PSNM=$O(^PSI(58.1,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
. S PSDA=0 F S PSDA=$O(^PSI(58.1,"B",PSNM,PSDA)) Q:PSDA'>0 D Q:PSQUIT
.. D BRK Q:PSQUIT
.. S C=C+1
.. W !,PSNM
.. S IEN=PSDA_",1",PSDIV=$$GET1^DIQ(59.79001,IEN,.02),PSOP=$$GET1^DIQ(59.79001,IEN,.03) W:$L(PSDIV) ?30,"Div: ",PSDIV W:$L(PSOP) ?30,"Op: ",PSOP
.. S PSINADT=$$GET1^DIQ(58.1,PSDA,3,"I") I PSINADT W ?60,$$FMTE^XLFDT(PSINADT,"D")
W !
D PG Q:PSQUIT
;
NAOU ;CS NAOU Drug Accountability 'Primary
Q:PSQUIT
S HDR="CS NAOU" D PGH1
S C=0
S PSNM="" F S PSNM=$O(^PSD(58.8,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
. S PSDA=0 F S PSDA=$O(^PSD(58.8,"B",PSNM,PSDA)) Q:PSDA'>0 D
.. S PSN0=^PSD(58.8,PSDA,0),PSTYP=$P(PSN0,U,2),PSINADT=+$G(^PSD(58.8,PSDA,"I"))
.. I PSTYP="P" Q
.. D BRK Q:PSQUIT
.. S C=C+1
.. W !,PSNM
.. S IEN=PSDA_",1",PSDIV=$$GET1^DIQ(59.79002,IEN,.02),PSOP=$$GET1^DIQ(59.79002,IEN,.03) W:$L(PSDIV) ?30,"Div: ",PSDIV W:$L(PSOP) ?30,"Op: ",PSOP
.. S PSINADT=$$GET1^DIQ(58.8,PSDA,4,"I")
.. I PSINADT W ?60,$$FMTE^XLFDT(PSINADT,"D")
W !
D PG Q:PSQUIT
;
DRACC ;
Q:PSQUIT
S HDR="DRUG ACCOUNTABILITY"
D PGH1
S C=0
S PSNM="" F S PSNM=$O(^PSD(58.8,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
. S PSDA=0 F S PSDA=$O(^PSD(58.8,"B",PSNM,PSDA)) Q:'PSDA D
.. S PSN0=^PSD(58.8,PSDA,0),PSTYP=$P(PSN0,U,2)
.. S PSINADT=+$G(^PSD(58.8,PSDA,"I"))
.. I PSTYP'="P" Q
.. D BRK Q:PSQUIT
.. S C=C+1
.. W !,PSNM
.. S IEN=PSDA_",1",PSDIV=$$GET1^DIQ(59.79003,IEN,.02),PSOP=$$GET1^DIQ(59.79003,IEN,.03) W:$L(PSDIV) ?30,"Div: ",PSDIV W:$L(PSOP) ?30,"Op: ",PSOP
.. S PSINADT=$$GET1^DIQ(58.8,PSDA,4,"I")
.. I PSINADT W ?60,$$FMTE^XLFDT(PSINADT,"D")
;
I $E(IOST)="C" W !! K DIR S DIR(0)="EA",DIR("A")="Report Finished <cr>" D ^DIR
Q
EN1 ;Scan for unmapped locations
;Called from PSUOP0
;
N PSULOC,PSULOC1,PSULOC2
S PSQUIT=0
D AOU1 ;Look for AR/WS AOU's
D NAOU1 ;Look for CS NAOU's
D DRACC1 ;Look for Drug Accountability Pharmacy Locations
D UNMAPD
D MAPD
Q
;
AOU1 ;Find AR/WS AOU's and set unmapped locations into AOU array
;
S PSULOC=" AR/WS AOU's "
;
K AOU
S PSNM="" F S PSNM=$O(^PSI(58.1,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
.S PSDA=0 F S PSDA=$O(^PSI(58.1,"B",PSNM,PSDA)) Q:PSDA'>0 D
..S IEN=PSDA_",1",PSDIV=$$GET1^DIQ(59.79001,IEN,.02)
..S PSOP=$$GET1^DIQ(59.79001,IEN,.03)
..I '$L(PSDIV),'$L(PSOP) S AOU(PSNM,PSDA)=$$GET1^DIQ(58.1,PSDA,3)
Q
;
NAOU1 ;Find Controlled Substances AOU's and set unmapped locations
;into NAOU array
;
S PSULOC1=" CS NAOUs "
;
K NAOU
S PSNM="" F S PSNM=$O(^PSD(58.8,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
.S PSDA=0
.F S PSDA=$O(^PSD(58.8,"B",PSNM,PSDA)) Q:PSDA'>0 D
..S PSN0=^PSD(58.8,PSDA,0)
..S PSTYP=$P(PSN0,U,2)
..S PSINADT=+$G(^PSD(58.8,PSDA,"I"))
..I PSTYP="P" Q
..S IEN=PSDA_",1"
..S PSDIV=$$GET1^DIQ(59.79002,IEN,.02)
..S PSOP=$$GET1^DIQ(59.79002,IEN,.03)
..I '$L(PSDIV),'$L(PSOP) S NAOU(PSNM,PSDA)=$$GET1^DIQ(58.8,PSDA,4)
Q
;
DRACC1 ;Find DA Pharmacy Locations and set unmapped locations into DRAC array
;
S PSULOC2=" DA Pharmacy Locations "
;
K DRAC
S PSNM="" F S PSNM=$O(^PSD(58.8,"B",PSNM)) Q:PSNM="" D Q:PSQUIT
.S PSDA=0
.F S PSDA=$O(^PSD(58.8,"B",PSNM,PSDA)) Q:'PSDA D
..S PSN0=^PSD(58.8,PSDA,0),PSTYP=$P(PSN0,U,2)
..S PSINADT=+$G(^PSD(58.8,PSDA,"I"))
..I PSTYP'="P" Q
..S IEN=PSDA_",1"
..S PSDIV=$$GET1^DIQ(59.79003,IEN,.02)
..S PSOP=$$GET1^DIQ(59.79003,IEN,.03)
..I '$L(PSDIV),'$L(PSOP) S DRAC(PSNM,PSDA)=$$GET1^DIQ(58.8,PSDA,4)
Q
;
MAPD ;Display this if all locations are mapped
;
I '$D(AOU),'$D(NAOU),'$D(DRAC) D Q
. W !!,?3,"All pharmacy dispensing/procurement locations are mapped.",!
Q
;
UNMAPD ;Display this if unmapped locations exist
;
N C
W !
I $D(AOU) S PSNM="" D ;Unmapped AR/WS AOU's
.S C=0
.W !,?5,"The following"_PSULOC_"are not mapped:"
.W !
.F S PSNM=$O(AOU(PSNM)) Q:PSNM="" D Q:PSQUIT
..S PSDA=0
..F S PSDA=$O(AOU(PSNM,PSDA)) Q:PSDA'>0 D Q:PSQUIT
...W !,?10,PSNM
...I AOU(PSNM,PSDA)'="" W ?40,"**Inactive**"
...D BRK Q:PSQUIT
...I C=(IOSL-5) S C=0
...S C=C+1
W !
D PG Q:PSQUIT
;
I $D(NAOU) S PSNM="" D ;Unmapped CS NAOUs
.S C=0
.W !,?5,"The following"_PSULOC1_"are not mapped:"
.W !
.F S PSNM=$O(NAOU(PSNM)) Q:PSNM="" D Q:PSQUIT
..S PSDA=0
..F S PSDA=$O(NAOU(PSNM,PSDA)) Q:PSDA'>0 D Q:PSQUIT
...W !,?10,PSNM
...I NAOU(PSNM,PSDA)'="" W ?40,"**Inactive**"
...D BRK Q:PSQUIT
...I C=(IOSL-5) S C=0
...S C=C+1
W !
D PG Q:PSQUIT
;
I $D(DRAC) S PSNM="" D ;Unmapped DA Pharmacy Locations
.S C=0
.W !,?5,"The following"_PSULOC2_"are not mapped:"
.W !
.F S PSNM=$O(DRAC(PSNM)) Q:PSNM="" D Q:PSQUIT
..S PSDA=0
..F S PSDA=$O(DRAC(PSNM,PSDA)) Q:PSDA'>0 D Q:PSQUIT
...W !,?10,PSNM
...I DRAC(PSNM,PSDA)'="" W ?40,"**Inactive**"
...D BRK Q:PSQUIT
...I C=(IOSL-5) S C=0
...S C=C+1
W !
D PG Q:PSQUIT
Q
;
BRK ;Page break. Occurs in the middle of a list
;
I C=(IOSL-5) D
.W !
.K DIR I $E(IOST)="C" S DIR(0)="E" D ^DIR
.I $D(Y),Y=0 S PSQUIT=1 Q
.S PG=$G(PG)+1
.W @IOF
;Q:$E(IOST,1,2)'="C-"!($D(IO("S")))
;K DIR W !
;S DIR(0)="E" D ^DIR K DIR
;I 'Y S PSQUIT=1 Q
Q
;
PG ;Page break between headers
;
K DIR I $E(IOST)="C" S DIR(0)="E" D ^DIR I Y=0 S PSQUIT=1 Q
S PG=$G(PG)+1
W @IOF
Q
;
PGH W @IOF
W !,"MAPPED/UNMAPPED LOCATIONS"
W ?30,$$FMTE^XLFDT(DT)
S PG=$G(PG)+1 W ?60,"PAGE: ",PG,!,LINE,!,"NAME",?30,"DIVISION/OUTPATIENT SITE",?60,"INACTIVE DATE"
PGH1 I $L(HDR) W !!,$G(HDR),!,LINE2
Q
PGB I $Y<(IOSL-4) S PSQUIT=1 Q
PGHB W @IOF
W !,"UNMAPPED LOCATIONS"
W ?30,$$FMTE^XLFDT(DT)
S PG=$G(PG)+1 W ?60,"PAGE: ",PG,!,LINE,!,"NAME",?40,"INACTIVE DATE"
PGH1B I $L(HDR) W !!,$G(HDR),!,LINE2
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSUMAPR 6326 printed Dec 13, 2024@02:28:04 Page 2
PSUMAPR ;BHM/PDW-REPORT OF MAP OAU,NAOU,DA LOCATION TO DIVISION/OUTPATIENT SITES ; 9SEP2003
+1 ;;4.0;PHARMACY BENEFITS MANAGEMENT;**7,9**;MARCH, 2005;Build 6
+2 ;
+3 ;DBIA's
+4 ; Reference to file (#58.1) supported by DBIA 2515
+5 ; Reference to file (#58.8) supported by DBIA 2519
+6 ; Reference to file (#59.7) supported by DBIA 2854
+7 ;
EN ; select Editing or Report of Mapping
+1 NEW C
+2 KILL PG,LINE,LINE2
+3 SET PSQUIT=0
SET HDR=""
SET $PIECE(LINE,"=",79)=""
SET $PIECE(LINE2,"-",15)=""
+4 DO PGH
AOU SET HDR="AR/WS AOU"
DO PGH1
+1 SET C=0
+2 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSI(58.1,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+3 SET PSDA=0
FOR
SET PSDA=$ORDER(^PSI(58.1,"B",PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:2
+4 DO BRK
if PSQUIT
QUIT
+5 SET C=C+1
+6 WRITE !,PSNM
+7 SET IEN=PSDA_",1"
SET PSDIV=$$GET1^DIQ(59.79001,IEN,.02)
SET PSOP=$$GET1^DIQ(59.79001,IEN,.03)
if $LENGTH(PSDIV)
WRITE ?30,"Div: ",PSDIV
if $LENGTH(PSOP)
WRITE ?30,"Op: ",PSOP
+8 SET PSINADT=$$GET1^DIQ(58.1,PSDA,3,"I")
IF PSINADT
WRITE ?60,$$FMTE^XLFDT(PSINADT,"D")
End DoDot:2
if PSQUIT
QUIT
End DoDot:1
if PSQUIT
QUIT
+9 WRITE !
+10 DO PG
if PSQUIT
QUIT
+11 ;
NAOU ;CS NAOU Drug Accountability 'Primary
+1 if PSQUIT
QUIT
+2 SET HDR="CS NAOU"
DO PGH1
+3 SET C=0
+4 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSD(58.8,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+5 SET PSDA=0
FOR
SET PSDA=$ORDER(^PSD(58.8,"B",PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:2
+6 SET PSN0=^PSD(58.8,PSDA,0)
SET PSTYP=$PIECE(PSN0,U,2)
SET PSINADT=+$GET(^PSD(58.8,PSDA,"I"))
+7 IF PSTYP="P"
QUIT
+8 DO BRK
if PSQUIT
QUIT
+9 SET C=C+1
+10 WRITE !,PSNM
+11 SET IEN=PSDA_",1"
SET PSDIV=$$GET1^DIQ(59.79002,IEN,.02)
SET PSOP=$$GET1^DIQ(59.79002,IEN,.03)
if $LENGTH(PSDIV)
WRITE ?30,"Div: ",PSDIV
if $LENGTH(PSOP)
WRITE ?30,"Op: ",PSOP
+12 SET PSINADT=$$GET1^DIQ(58.8,PSDA,4,"I")
+13 IF PSINADT
WRITE ?60,$$FMTE^XLFDT(PSINADT,"D")
End DoDot:2
End DoDot:1
if PSQUIT
QUIT
+14 WRITE !
+15 DO PG
if PSQUIT
QUIT
+16 ;
DRACC ;
+1 if PSQUIT
QUIT
+2 SET HDR="DRUG ACCOUNTABILITY"
+3 DO PGH1
+4 SET C=0
+5 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSD(58.8,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+6 SET PSDA=0
FOR
SET PSDA=$ORDER(^PSD(58.8,"B",PSNM,PSDA))
if 'PSDA
QUIT
Begin DoDot:2
+7 SET PSN0=^PSD(58.8,PSDA,0)
SET PSTYP=$PIECE(PSN0,U,2)
+8 SET PSINADT=+$GET(^PSD(58.8,PSDA,"I"))
+9 IF PSTYP'="P"
QUIT
+10 DO BRK
if PSQUIT
QUIT
+11 SET C=C+1
+12 WRITE !,PSNM
+13 SET IEN=PSDA_",1"
SET PSDIV=$$GET1^DIQ(59.79003,IEN,.02)
SET PSOP=$$GET1^DIQ(59.79003,IEN,.03)
if $LENGTH(PSDIV)
WRITE ?30,"Div: ",PSDIV
if $LENGTH(PSOP)
WRITE ?30,"Op: ",PSOP
+14 SET PSINADT=$$GET1^DIQ(58.8,PSDA,4,"I")
+15 IF PSINADT
WRITE ?60,$$FMTE^XLFDT(PSINADT,"D")
End DoDot:2
End DoDot:1
if PSQUIT
QUIT
+16 ;
+17 IF $EXTRACT(IOST)="C"
WRITE !!
KILL DIR
SET DIR(0)="EA"
SET DIR("A")="Report Finished <cr>"
DO ^DIR
+18 QUIT
EN1 ;Scan for unmapped locations
+1 ;Called from PSUOP0
+2 ;
+3 NEW PSULOC,PSULOC1,PSULOC2
+4 SET PSQUIT=0
+5 ;Look for AR/WS AOU's
DO AOU1
+6 ;Look for CS NAOU's
DO NAOU1
+7 ;Look for Drug Accountability Pharmacy Locations
DO DRACC1
+8 DO UNMAPD
+9 DO MAPD
+10 QUIT
+11 ;
AOU1 ;Find AR/WS AOU's and set unmapped locations into AOU array
+1 ;
+2 SET PSULOC=" AR/WS AOU's "
+3 ;
+4 KILL AOU
+5 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSI(58.1,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+6 SET PSDA=0
FOR
SET PSDA=$ORDER(^PSI(58.1,"B",PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:2
+7 SET IEN=PSDA_",1"
SET PSDIV=$$GET1^DIQ(59.79001,IEN,.02)
+8 SET PSOP=$$GET1^DIQ(59.79001,IEN,.03)
+9 IF '$LENGTH(PSDIV)
IF '$LENGTH(PSOP)
SET AOU(PSNM,PSDA)=$$GET1^DIQ(58.1,PSDA,3)
End DoDot:2
End DoDot:1
if PSQUIT
QUIT
+10 QUIT
+11 ;
NAOU1 ;Find Controlled Substances AOU's and set unmapped locations
+1 ;into NAOU array
+2 ;
+3 SET PSULOC1=" CS NAOUs "
+4 ;
+5 KILL NAOU
+6 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSD(58.8,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+7 SET PSDA=0
+8 FOR
SET PSDA=$ORDER(^PSD(58.8,"B",PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:2
+9 SET PSN0=^PSD(58.8,PSDA,0)
+10 SET PSTYP=$PIECE(PSN0,U,2)
+11 SET PSINADT=+$GET(^PSD(58.8,PSDA,"I"))
+12 IF PSTYP="P"
QUIT
+13 SET IEN=PSDA_",1"
+14 SET PSDIV=$$GET1^DIQ(59.79002,IEN,.02)
+15 SET PSOP=$$GET1^DIQ(59.79002,IEN,.03)
+16 IF '$LENGTH(PSDIV)
IF '$LENGTH(PSOP)
SET NAOU(PSNM,PSDA)=$$GET1^DIQ(58.8,PSDA,4)
End DoDot:2
End DoDot:1
if PSQUIT
QUIT
+17 QUIT
+18 ;
DRACC1 ;Find DA Pharmacy Locations and set unmapped locations into DRAC array
+1 ;
+2 SET PSULOC2=" DA Pharmacy Locations "
+3 ;
+4 KILL DRAC
+5 SET PSNM=""
FOR
SET PSNM=$ORDER(^PSD(58.8,"B",PSNM))
if PSNM=""
QUIT
Begin DoDot:1
+6 SET PSDA=0
+7 FOR
SET PSDA=$ORDER(^PSD(58.8,"B",PSNM,PSDA))
if 'PSDA
QUIT
Begin DoDot:2
+8 SET PSN0=^PSD(58.8,PSDA,0)
SET PSTYP=$PIECE(PSN0,U,2)
+9 SET PSINADT=+$GET(^PSD(58.8,PSDA,"I"))
+10 IF PSTYP'="P"
QUIT
+11 SET IEN=PSDA_",1"
+12 SET PSDIV=$$GET1^DIQ(59.79003,IEN,.02)
+13 SET PSOP=$$GET1^DIQ(59.79003,IEN,.03)
+14 IF '$LENGTH(PSDIV)
IF '$LENGTH(PSOP)
SET DRAC(PSNM,PSDA)=$$GET1^DIQ(58.8,PSDA,4)
End DoDot:2
End DoDot:1
if PSQUIT
QUIT
+15 QUIT
+16 ;
MAPD ;Display this if all locations are mapped
+1 ;
+2 IF '$DATA(AOU)
IF '$DATA(NAOU)
IF '$DATA(DRAC)
Begin DoDot:1
+3 WRITE !!,?3,"All pharmacy dispensing/procurement locations are mapped.",!
End DoDot:1
QUIT
+4 QUIT
+5 ;
UNMAPD ;Display this if unmapped locations exist
+1 ;
+2 NEW C
+3 WRITE !
+4 ;Unmapped AR/WS AOU's
IF $DATA(AOU)
SET PSNM=""
Begin DoDot:1
+5 SET C=0
+6 WRITE !,?5,"The following"_PSULOC_"are not mapped:"
+7 WRITE !
+8 FOR
SET PSNM=$ORDER(AOU(PSNM))
if PSNM=""
QUIT
Begin DoDot:2
+9 SET PSDA=0
+10 FOR
SET PSDA=$ORDER(AOU(PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:3
+11 WRITE !,?10,PSNM
+12 IF AOU(PSNM,PSDA)'=""
WRITE ?40,"**Inactive**"
+13 DO BRK
if PSQUIT
QUIT
+14 IF C=(IOSL-5)
SET C=0
+15 SET C=C+1
End DoDot:3
if PSQUIT
QUIT
End DoDot:2
if PSQUIT
QUIT
End DoDot:1
+16 WRITE !
+17 DO PG
if PSQUIT
QUIT
+18 ;
+19 ;Unmapped CS NAOUs
IF $DATA(NAOU)
SET PSNM=""
Begin DoDot:1
+20 SET C=0
+21 WRITE !,?5,"The following"_PSULOC1_"are not mapped:"
+22 WRITE !
+23 FOR
SET PSNM=$ORDER(NAOU(PSNM))
if PSNM=""
QUIT
Begin DoDot:2
+24 SET PSDA=0
+25 FOR
SET PSDA=$ORDER(NAOU(PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:3
+26 WRITE !,?10,PSNM
+27 IF NAOU(PSNM,PSDA)'=""
WRITE ?40,"**Inactive**"
+28 DO BRK
if PSQUIT
QUIT
+29 IF C=(IOSL-5)
SET C=0
+30 SET C=C+1
End DoDot:3
if PSQUIT
QUIT
End DoDot:2
if PSQUIT
QUIT
End DoDot:1
+31 WRITE !
+32 DO PG
if PSQUIT
QUIT
+33 ;
+34 ;Unmapped DA Pharmacy Locations
IF $DATA(DRAC)
SET PSNM=""
Begin DoDot:1
+35 SET C=0
+36 WRITE !,?5,"The following"_PSULOC2_"are not mapped:"
+37 WRITE !
+38 FOR
SET PSNM=$ORDER(DRAC(PSNM))
if PSNM=""
QUIT
Begin DoDot:2
+39 SET PSDA=0
+40 FOR
SET PSDA=$ORDER(DRAC(PSNM,PSDA))
if PSDA'>0
QUIT
Begin DoDot:3
+41 WRITE !,?10,PSNM
+42 IF DRAC(PSNM,PSDA)'=""
WRITE ?40,"**Inactive**"
+43 DO BRK
if PSQUIT
QUIT
+44 IF C=(IOSL-5)
SET C=0
+45 SET C=C+1
End DoDot:3
if PSQUIT
QUIT
End DoDot:2
if PSQUIT
QUIT
End DoDot:1
+46 WRITE !
+47 DO PG
if PSQUIT
QUIT
+48 QUIT
+49 ;
BRK ;Page break. Occurs in the middle of a list
+1 ;
+2 IF C=(IOSL-5)
Begin DoDot:1
+3 WRITE !
+4 KILL DIR
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
+5 IF $DATA(Y)
IF Y=0
SET PSQUIT=1
QUIT
+6 SET PG=$GET(PG)+1
+7 WRITE @IOF
End DoDot:1
+8 ;Q:$E(IOST,1,2)'="C-"!($D(IO("S")))
+9 ;K DIR W !
+10 ;S DIR(0)="E" D ^DIR K DIR
+11 ;I 'Y S PSQUIT=1 Q
+12 QUIT
+13 ;
PG ;Page break between headers
+1 ;
+2 KILL DIR
IF $EXTRACT(IOST)="C"
SET DIR(0)="E"
DO ^DIR
IF Y=0
SET PSQUIT=1
QUIT
+3 SET PG=$GET(PG)+1
+4 WRITE @IOF
+5 QUIT
+6 ;
PGH WRITE @IOF
+1 WRITE !,"MAPPED/UNMAPPED LOCATIONS"
+2 WRITE ?30,$$FMTE^XLFDT(DT)
+3 SET PG=$GET(PG)+1
WRITE ?60,"PAGE: ",PG,!,LINE,!,"NAME",?30,"DIVISION/OUTPATIENT SITE",?60,"INACTIVE DATE"
PGH1 IF $LENGTH(HDR)
WRITE !!,$GET(HDR),!,LINE2
+1 QUIT
PGB IF $Y<(IOSL-4)
SET PSQUIT=1
QUIT
PGHB WRITE @IOF
+1 WRITE !,"UNMAPPED LOCATIONS"
+2 WRITE ?30,$$FMTE^XLFDT(DT)
+3 SET PG=$GET(PG)+1
WRITE ?60,"PAGE: ",PG,!,LINE,!,"NAME",?40,"INACTIVE DATE"
PGH1B IF $LENGTH(HDR)
WRITE !!,$GET(HDR),!,LINE2
+1 QUIT
