- SDSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03
- ;;5.3;Scheduling;**317,547**;Aug 13, 1993;Build 17
- ;
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDSCRP 3242 printed Jan 18, 2025@04:02:27 Page 2
- SDSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03
- +1 ;;5.3;Scheduling;**317,547**;Aug 13, 1993;Build 17
- +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