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