SDSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03
;;5.3;PIMS;**317,1015,1016**;JUN 30, 2012;Build 20
;
EN ;foreground entry point
N ZTRTN,ZTDESC,ZTIO,ZTQUEUED,SDPCF,DIR,DIRUT,X,Y
W @IOF
S DIR(0)="SO^A:Active Clinics;I:Inactive Clinics;B:Both"
S DIR("A")="Select Report"
S DIR("?",1)="Enter an A for Active Clinics, I for Inactive Clinics,"
S DIR("?")="B for Both Active and Inactive Clinics"
D ^DIR K DIR I $D(DIRUT) G END
S SDPCF=Y
;device selection
K IOP,%ZIS,POP,IO("Q")
S %ZIS("A")="Select Device: ",%ZIS="QM" D ^%ZIS I POP G END
I $D(IO("Q")) K IO("Q") D G END
.S ZTDESC="Non-Conforming Clinics Stop Code Report",ZTSAVE("SDPCF")=""
.S ZTRTN="PROCESS^SDSCRP",ZTIO=ION D ^%ZTLOAD,HOME^%ZIS K ZTSK
U IO
D PROCESS
END D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
PROCESS ;background entry point
;locate invalid Stop Code in HOSPITAL LOCATION file #44
N NAM,IDT,RDT,IDAT,STR,ECX,IEN,PSC,SSC,PSCN,SSCN,CNTX,SDPG,SDOUT,SDF,LNS
N ACF,SDRDT
S %H=$H D YX^%DTC S SDRDT=Y
S $P(LNS,"-",80)="",(CNTX,IEN,SDOUT,SDF)=0,SDPG=1
D HDR
;search file #44 for invalid entries
F S IEN=$O(^SC(IEN)) Q:'IEN D Q:SDOUT S:SDF CNTX=CNTX+1
.S ECX=$G(^SC(IEN,0)),PSC=$P(ECX,U,7),SSC=$P(ECX,U,18),SDF=0
.I $P(ECX,U,3)'="C" Q
.S NAM=$P(ECX,U),IDAT=$G(^SC(IEN,"I")) I IDAT'="" D
..S IDT=$P(IDAT,U),RDT=$P(IDAT,U,2) Q:IDT="" I RDT="" S NAM="*"_NAM Q
..I RDT>IDT S NAM="*"_NAM
.S ACF=$S($E(NAM)="*":0,1:1)
.I $S((SDPCF="A")&('ACF):1,(SDPCF="I")&(ACF):1,1:0) Q
.S PSCN=$S(PSC:$P($G(^DIC(40.7,PSC,0)),U,2),1:"")
.S SSCN=$S(SSC:$P($G(^DIC(40.7,SSC,0)),U,2),1:"")
.D I SDOUT Q
..I PSC="" S STR="Missing primary code" D PRN Q
..D SCCHK(PSC,"P") I $D(STR) D PRN
.I SSC'="" D SCCHK(SSC,"S") I $D(STR) D PRN
W !!,?25,$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
K SCIEN,TYP
Q
;
PRN ;print line
I ($Y+3)>IOSL D PAGE,HDR I SDOUT Q
W !,IEN,?8,$E(NAM,1,28),?37,PSCN,?46,SSCN,?57,STR
S SDF=1
Q
;
SCCHK(SCIEN,TYP) ;check stop code against file 40.7; var INACT added SD*547
N SCN,RTY,CTY,INACT
K STR
S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
S SCN=$G(^DIC(40.7,SCIEN,0)),RTY=$P(SCN,U,6),INACT=$P(SCN,U,3),SCN=$P(SCN,U,2)
I INACT S STR=SCN_" Inactivated "_$$FMTE^XLFDT(INACT,2) Q ;SD*5.3*547
I SCN="" D Q
.S STR=SCIEN_" Inv "_$S(TYP="P":"prim",1:"2nd")_" pointr"
I RTY="" S STR=SCN_" No restriction type" Q
I CTY'[("^"_RTY_"^") D
.S STR=SCN_" cannot be "_$S(TYP="P":"prim",1:"second")_"ary"
Q
;
HDR ;Header for data from file #44
W @IOF
W SDRDT,?73,"Page: ",SDPG,!
W !,?18,"NON-CONFORMING CLINICS STOP CODE REPORT",!,?32
W $S(SDPCF="A":"Active",SDPCF="I":"Inactive",1:"All")_" Clinics",!
W !,"HOSPITAL LOCATION FILE (#44) - (Use Set up a Clinic [SDBUILD]"
W " menu option to",!,?32,"make corrections)"
W !!,?37,"PRIMARY",?46,"SECONDARY",?57,"REASON FOR"
W !?8,$S(SDPCF="B":"CLINIC NAME",1:""),?37,"STOP",?46,"CREDIT",?57,"NON"
W !,"IEN",?8,$S(SDPCF="B":"(*currently inactive)",1:"CLINIC NAME")
W ?37,"CODE",?46,"STOP CODE",?57,"CONFORMANCE",!,$E(LNS,1,80)
S SDPG=SDPG+1
Q
;
PAGE ;
N SS,JJ,DIR,X,Y
I $E(IOST,1,2)="C-" D
. S SS=22-$Y F JJ=1:1:SS W !
. S DIR(0)="E" W ! D ^DIR K DIR I 'Y S SDOUT=1
Q
SDSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03
+1 ;;5.3;PIMS;**317,1015,1016**;JUN 30, 2012;Build 20
+2 ;
EN ;foreground entry point
+1 NEW ZTRTN,ZTDESC,ZTIO,ZTQUEUED,SDPCF,DIR,DIRUT,X,Y
+2 WRITE @IOF
+3 SET DIR(0)="SO^A:Active Clinics;I:Inactive Clinics;B:Both"
+4 SET DIR("A")="Select Report"
+5 SET DIR("?",1)="Enter an A for Active Clinics, I for Inactive Clinics,"
+6 SET DIR("?")="B for Both Active and Inactive Clinics"
+7 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO END
+8 SET SDPCF=Y
+9 ;device selection
+10 KILL IOP,%ZIS,POP,IO("Q")
+11 SET %ZIS("A")="Select Device: "
SET %ZIS="QM"
DO ^%ZIS
IF POP
GOTO END
+12 IF $DATA(IO("Q"))
KILL IO("Q")
Begin DoDot:1
+13 SET ZTDESC="Non-Conforming Clinics Stop Code Report"
SET ZTSAVE("SDPCF")=""
+14 SET ZTRTN="PROCESS^SDSCRP"
SET ZTIO=ION
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO END
+15 USE IO
+16 DO PROCESS
END DO ^%ZISC
IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+1 QUIT
+2 ;
PROCESS ;background entry point
+1 ;locate invalid Stop Code in HOSPITAL LOCATION file #44
+2 NEW NAM,IDT,RDT,IDAT,STR,ECX,IEN,PSC,SSC,PSCN,SSCN,CNTX,SDPG,SDOUT,SDF,LNS
+3 NEW ACF,SDRDT
+4 SET %H=$HOROLOG
DO YX^%DTC
SET SDRDT=Y
+5 SET $PIECE(LNS,"-",80)=""
SET (CNTX,IEN,SDOUT,SDF)=0
SET SDPG=1
+6 DO HDR
+7 ;search file #44 for invalid entries
+8 FOR
SET IEN=$ORDER(^SC(IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 SET ECX=$GET(^SC(IEN,0))
SET PSC=$PIECE(ECX,U,7)
SET SSC=$PIECE(ECX,U,18)
SET SDF=0
+10 IF $PIECE(ECX,U,3)'="C"
QUIT
+11 SET NAM=$PIECE(ECX,U)
SET IDAT=$GET(^SC(IEN,"I"))
IF IDAT'=""
Begin DoDot:2
+12 SET IDT=$PIECE(IDAT,U)
SET RDT=$PIECE(IDAT,U,2)
IF IDT=""
QUIT
IF RDT=""
SET NAM="*"_NAM
QUIT
+13 IF RDT>IDT
SET NAM="*"_NAM
End DoDot:2
+14 SET ACF=$SELECT($EXTRACT(NAM)="*":0,1:1)
+15 IF $SELECT((SDPCF="A")&('ACF):1,(SDPCF="I")&(ACF):1,1:0)
QUIT
+16 SET PSCN=$SELECT(PSC:$PIECE($GET(^DIC(40.7,PSC,0)),U,2),1:"")
+17 SET SSCN=$SELECT(SSC:$PIECE($GET(^DIC(40.7,SSC,0)),U,2),1:"")
+18 Begin DoDot:2
+19 IF PSC=""
SET STR="Missing primary code"
DO PRN
QUIT
+20 DO SCCHK(PSC,"P")
IF $DATA(STR)
DO PRN
End DoDot:2
IF SDOUT
QUIT
+21 IF SSC'=""
DO SCCHK(SSC,"S")
IF $DATA(STR)
DO PRN
End DoDot:1
IF SDOUT
QUIT
IF SDF
SET CNTX=CNTX+1
+22 WRITE !!,?25,$SELECT(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
+23 KILL SCIEN,TYP
+24 QUIT
+25 ;
PRN ;print line
+1 IF ($Y+3)>IOSL
DO PAGE
DO HDR
IF SDOUT
QUIT
+2 WRITE !,IEN,?8,$EXTRACT(NAM,1,28),?37,PSCN,?46,SSCN,?57,STR
+3 SET SDF=1
+4 QUIT
+5 ;
SCCHK(SCIEN,TYP) ;check stop code against file 40.7; var INACT added SD*547
+1 NEW SCN,RTY,CTY,INACT
+2 KILL STR
+3 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
+4 SET SCN=$GET(^DIC(40.7,SCIEN,0))
SET RTY=$PIECE(SCN,U,6)
SET INACT=$PIECE(SCN,U,3)
SET SCN=$PIECE(SCN,U,2)
+5 ;SD*5.3*547
IF INACT
SET STR=SCN_" Inactivated "_$$FMTE^XLFDT(INACT,2)
QUIT
+6 IF SCN=""
Begin DoDot:1
+7 SET STR=SCIEN_" Inv "_$SELECT(TYP="P":"prim",1:"2nd")_" pointr"
End DoDot:1
QUIT
+8 IF RTY=""
SET STR=SCN_" No restriction type"
QUIT
+9 IF CTY'[("^"_RTY_"^")
Begin DoDot:1
+10 SET STR=SCN_" cannot be "_$SELECT(TYP="P":"prim",1:"second")_"ary"
End DoDot:1
+11 QUIT
+12 ;
HDR ;Header for data from file #44
+1 WRITE @IOF
+2 WRITE SDRDT,?73,"Page: ",SDPG,!
+3 WRITE !,?18,"NON-CONFORMING CLINICS STOP CODE REPORT",!,?32
+4 WRITE $SELECT(SDPCF="A":"Active",SDPCF="I":"Inactive",1:"All")_" Clinics",!
+5 WRITE !,"HOSPITAL LOCATION FILE (#44) - (Use Set up a Clinic [SDBUILD]"
+6 WRITE " menu option to",!,?32,"make corrections)"
+7 WRITE !!,?37,"PRIMARY",?46,"SECONDARY",?57,"REASON FOR"
+8 WRITE !?8,$SELECT(SDPCF="B":"CLINIC NAME",1:""),?37,"STOP",?46,"CREDIT",?57,"NON"
+9 WRITE !,"IEN",?8,$SELECT(SDPCF="B":"(*currently inactive)",1:"CLINIC NAME")
+10 WRITE ?37,"CODE",?46,"STOP CODE",?57,"CONFORMANCE",!,$EXTRACT(LNS,1,80)
+11 SET SDPG=SDPG+1
+12 QUIT
+13 ;
PAGE ;
+1 NEW SS,JJ,DIR,X,Y
+2 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+3 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+4 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
IF 'Y
SET SDOUT=1
End DoDot:1
+5 QUIT
