- ECXSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03 ;2/11/14 16:56
- ;;3.0;DSS EXTRACTS;**57,58,120,126,144,149,154**;Dec 22, 1997;Build 13
- ;
- EN ;foreground entry point
- N ZTRTN,ZTDESC,ZTIO,ZTQUEUED,DIR,DIRUT,X,Y,ECX,ECXSD,PSC,SSC,ECXPCF,ECXPORT,CNT ;144
- W @IOF
- W !,"This option reviews the Primary and Secondary Stop Codes and any existing Four" ;144
- W !,"Character Codes in the Clinics and Stop Codes file #728.44." ;144
- W !,"It produces a report highlighting any nonconformance reasons that pertain" ;144
- W !,"to the Primary and Secondary Codes, or the Four Character Codes if present." ;144
- W !,"Please contact the responsible party for corrective action." ;144
- 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 ECXPCF=Y
- W !,"Please be patient, this may take a few moments..." ;144
- ;Synch primary & secondary stop codes from file #44 with #728.44
- S ECX=0 F S ECX=$O(^ECX(728.44,ECX)) Q:'ECX D FIX^ECXSCLD(ECX)
- S ECXPORT=$$EXPORT^ECXUTL1 Q:ECXPORT=-1 I ECXPORT D Q ;144
- .K ^TMP($J,"ECXPORT") ;144
- .S ^TMP($J,"ECXPORT",0)="IEN^CLINIC NAME^STOP CODE^CREDIT STOP CODE^CHAR4 CODE^REASON FOR NON-CONFORMANCE" ;144,149;154
- .S CNT=1 ;144
- .D PROCESS ;144
- .D EXPDISP^ECXUTL1 ;144
- ;device selection
- W !!,"** REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY **",!! ;144 CVW
- K IOP,%ZIS,POP,IO("Q")
- ;S %ZIS("A")="Select Device: ",%ZIS="QM" D ^%ZIS I POP G END
- S %ZIS="",%ZIS("B")="0;132;99999" D ^%ZIS I POP G END
- I $D(IO("Q")) K IO("Q") D G END
- .S ZTDESC="Restricted Stop Code Report",ZTSAVE("ECXPCF")="" ;154
- .S ZTRTN="PROCESS^ECXSCRP",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 & CLINICS
- ;AND STOP CODES file #728.44
- N ECX,NAM,STR,IEN,PSC,SSC,CNTX,ECXPG,ECXOUT,LNS,DPC,DSC,SCIEN,ECXF
- N INDT,TYP,ACF,HTYP,CLNF,ECXRDT,NCODE,%H ;144
- S %H=$H D YX^%DTC S ECXRDT=Y
- S $P(LNS,"-",132)="",(CNTX,IEN,ECXOUT,ECXF)=0,ECXPG=1,CLNF=0
- ;search file #728.44 for invalid stop code entries
- D:'$G(ECXPORT) HDR S IEN=0 ;144
- F S IEN=$O(^ECX(728.44,IEN)) Q:'IEN D Q:ECXOUT S:ECXF CNTX=CNTX+1
- .I $P($G(^SC(IEN,0)),U,3)'="C" Q ;149 If entry isn't a clinic, don't include it on report
- .S ECX=$G(^ECX(728.44,IEN,0)),PSC=$P(ECX,U,2),SSC=$P(ECX,U,3),CLNF=0
- .S DPC=$P(ECX,U,4),DSC=$P(ECX,U,5),NAM=$$GET1^DIQ(44,$P(ECX,U),.01)
- .S INDT=$P(ECX,U,10),ECXF=0 I INDT'="" S NAM="*"_NAM
- .S ACF=$S($E(NAM)="*":0,1:1),HTYP=$$GET1^DIQ(44,$P(ECX,U),2,"I")
- .S NCODE=$$GET1^DIQ(728.441,$P(ECX,U,8),.01) ;144 cvw
- .I $S((ECXPCF="A")&('ACF):1,(ECXPCF="I")&(ACF):1,1:0) Q
- .D I ECXOUT 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
- .D I ECXOUT Q
- ..;I DPC="" S STR="No DSS primary code" D PRN Q ;154
- ..;I DPC'=PSC D SCCHK(DPC,"P") I $D(STR) D PRN
- .;I DSC'="",DSC'=SSC D SCCHK(DSC,"S") I $D(STR) D PRN
- .D I ECXOUT Q ;144 cvw
- ..I ($P(ECX,U,8)'="")&(NCODE="") S NCODE=$P(ECX,U,8),STR="CHAR4 Code invalid" D PRN Q ;144,149 cvw
- ..I $$GET1^DIQ(728.441,$P(ECX,U,8),3)'="" S STR="CHAR4 Code inactive" D PRN Q ;144,149 cvw
- I '$G(ECXPORT) W !!,?25,$S(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND." ;144
- Q
- PRN ;print line
- Q:CLNF I HTYP'="C" S STR="Not a Clinic" S CLNF=1
- I $G(ECXPORT) S ^TMP($J,"ECXPORT",CNT)=IEN_"^"_NAM_"^"_PSC_"^"_SSC_"^"_NCODE_"^"_STR,CNT=CNT+1 Q ;154
- I ($Y+3)>IOSL D PAGE,HDR I ECXOUT Q
- W !,IEN,?14,$E(NAM,1,24),?48,PSC,?58,SSC,?75,NCODE,?91,STR ;CVW 149
- S ECXF=1
- Q
- ;
- SCCHK(SCIEN,TYP) ;check stop code against file 40.7
- N SCN,RTY,CTY,SCI,INACT,ARRY,I,FLG
- K STR
- S CTY=$S(TYP="P":"^P^E^",1:"^S^E^")
- D SCIEN(SCIEN) I SCI="" D Q
- .;S SCI=$$SCIEN(SCIEN) I SCI="" D Q
- .I TYP="S" Q:SSC=PSC Q:DSC=DPC
- .S STR=SCIEN_" Invalid Stop Code"
- S SCN=$G(^DIC(40.7,SCI,0)),RTY=$P(SCN,U,6),INACT=$P(SCN,U,3)
- I INACT D Q
- .I INACT>DT S STR=SCIEN_" Inactive in future"
- .E S STR=SCIEN_" Code is inactive"
- I $P(SCN,U,2)="" S STR="No pointer in file #40.7" Q
- I RTY="" S STR=SCIEN_" No restriction type" Q
- I CTY'[("^"_RTY_"^") D
- .S STR=SCIEN_" Cannot be "_$S(TYP="P":"prim",1:"second")_"ary"
- 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 ECXOUT=1
- Q
- ;
- SCIEN(SCIEN) ;Get stop code IEN
- I SCIEN="" Q ""
- ;S SCIEN=$O(^DIC(40.7,"C",SCIEN,0))
- ;Q SCIEN
- ;find active code if one
- S SCI=$O(^DIC(40.7,"C",SCIEN,0))
- I $O(^DIC(40.7,"C",SCIEN,SCI))'>0 Q
- ;must be some duplicates so find the best one
- S I=""
- F S I=$O(^DIC(40.7,"C",SCIEN,I)) Q:'I D
- . Q:'$D(^DIC(40.7,I,0))
- . S INACT=$P(^DIC(40.7,I,0),"^",3),FLG="A" D
- . . I INACT,((DT>INACT)!(DT=INACT)) S FLG="I"
- . S ARRY(FLG,I)=""
- I $D(ARRY("A")) S SCI=$O(ARRY("A",0))
- Q SCIEN
- ;
- HDR ;header for data from file #728.44
- W @IOF
- W ECXRDT,?73,"Page: ",ECXPG,!
- W !,?18,"STOP CODE NON-CONFORMING CLINICS REPORT",!,?32
- W $S(ECXPCF="A":"Active",ECXPCF="I":"Inactive",1:"All")_" Clinics",!
- W !,"CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
- W "Stop Codes for",!,?25,"Clinics' [ECXSCEDIT] menu option to "
- W "make corrections)",!! ;CVW 149
- W "IEN #",?14,$S(ECXPCF="B":"(*currently inactive)",1:"CLINIC NAME")
- W ?48,"STOP",?58,"CREDIT",?75,"CHAR4",?91,"REASON FOR NON-"
- W !,?48,"CODE",?58,"STOP CODE",?75,"CODE",?91,"CONFORMANCE"
- W !,$E(LNS,1,132)
- S ECXPG=ECXPG+1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXSCRP 5713 printed Mar 13, 2025@20:58:30 Page 2
- ECXSCRP ;ALB/JAM - Restricted Stop Code Nonconforming Clinic Report; 07/24/03 ;2/11/14 16:56
- +1 ;;3.0;DSS EXTRACTS;**57,58,120,126,144,149,154**;Dec 22, 1997;Build 13
- +2 ;
- EN ;foreground entry point
- +1 ;144
- NEW ZTRTN,ZTDESC,ZTIO,ZTQUEUED,DIR,DIRUT,X,Y,ECX,ECXSD,PSC,SSC,ECXPCF,ECXPORT,CNT
- +2 WRITE @IOF
- +3 ;144
- WRITE !,"This option reviews the Primary and Secondary Stop Codes and any existing Four"
- +4 ;144
- WRITE !,"Character Codes in the Clinics and Stop Codes file #728.44."
- +5 ;144
- WRITE !,"It produces a report highlighting any nonconformance reasons that pertain"
- +6 ;144
- WRITE !,"to the Primary and Secondary Codes, or the Four Character Codes if present."
- +7 ;144
- WRITE !,"Please contact the responsible party for corrective action."
- +8 SET DIR(0)="SO^A:Active Clinics;I:Inactive Clinics;B:Both"
- +9 SET DIR("A")="Select Report"
- +10 SET DIR("?",1)="Enter an A for Active Clinics, I for Inactive Clinics,"
- +11 SET DIR("?")="B for Both Active and Inactive Clinics"
- +12 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- GOTO END
- +13 SET ECXPCF=Y
- +14 ;144
- WRITE !,"Please be patient, this may take a few moments..."
- +15 ;Synch primary & secondary stop codes from file #44 with #728.44
- +16 SET ECX=0
- FOR
- SET ECX=$ORDER(^ECX(728.44,ECX))
- if 'ECX
- QUIT
- DO FIX^ECXSCLD(ECX)
- +17 ;144
- SET ECXPORT=$$EXPORT^ECXUTL1
- if ECXPORT=-1
- QUIT
- IF ECXPORT
- Begin DoDot:1
- +18 ;144
- KILL ^TMP($JOB,"ECXPORT")
- +19 ;144,149;154
- SET ^TMP($JOB,"ECXPORT",0)="IEN^CLINIC NAME^STOP CODE^CREDIT STOP CODE^CHAR4 CODE^REASON FOR NON-CONFORMANCE"
- +20 ;144
- SET CNT=1
- +21 ;144
- DO PROCESS
- +22 ;144
- DO EXPDISP^ECXUTL1
- End DoDot:1
- QUIT
- +23 ;device selection
- +24 ;144 CVW
- WRITE !!,"** REPORT REQUIRES 132 COLUMNS TO PRINT CORRECTLY **",!!
- +25 KILL IOP,%ZIS,POP,IO("Q")
- +26 ;S %ZIS("A")="Select Device: ",%ZIS="QM" D ^%ZIS I POP G END
- +27 SET %ZIS=""
- SET %ZIS("B")="0;132;99999"
- DO ^%ZIS
- IF POP
- GOTO END
- +28 IF $DATA(IO("Q"))
- KILL IO("Q")
- Begin DoDot:1
- +29 ;154
- SET ZTDESC="Restricted Stop Code Report"
- SET ZTSAVE("ECXPCF")=""
- +30 SET ZTRTN="PROCESS^ECXSCRP"
- SET ZTIO=ION
- DO ^%ZTLOAD
- DO HOME^%ZIS
- KILL ZTSK
- End DoDot:1
- GOTO END
- +31 USE IO
- +32 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 & CLINICS
- +2 ;AND STOP CODES file #728.44
- +3 NEW ECX,NAM,STR,IEN,PSC,SSC,CNTX,ECXPG,ECXOUT,LNS,DPC,DSC,SCIEN,ECXF
- +4 ;144
- NEW INDT,TYP,ACF,HTYP,CLNF,ECXRDT,NCODE,%H
- +5 SET %H=$HOROLOG
- DO YX^%DTC
- SET ECXRDT=Y
- +6 SET $PIECE(LNS,"-",132)=""
- SET (CNTX,IEN,ECXOUT,ECXF)=0
- SET ECXPG=1
- SET CLNF=0
- +7 ;search file #728.44 for invalid stop code entries
- +8 ;144
- if '$GET(ECXPORT)
- DO HDR
- SET IEN=0
- +9 FOR
- SET IEN=$ORDER(^ECX(728.44,IEN))
- if 'IEN
- QUIT
- Begin DoDot:1
- +10 ;149 If entry isn't a clinic, don't include it on report
- IF $PIECE($GET(^SC(IEN,0)),U,3)'="C"
- QUIT
- +11 SET ECX=$GET(^ECX(728.44,IEN,0))
- SET PSC=$PIECE(ECX,U,2)
- SET SSC=$PIECE(ECX,U,3)
- SET CLNF=0
- +12 SET DPC=$PIECE(ECX,U,4)
- SET DSC=$PIECE(ECX,U,5)
- SET NAM=$$GET1^DIQ(44,$PIECE(ECX,U),.01)
- +13 SET INDT=$PIECE(ECX,U,10)
- SET ECXF=0
- IF INDT'=""
- SET NAM="*"_NAM
- +14 SET ACF=$SELECT($EXTRACT(NAM)="*":0,1:1)
- SET HTYP=$$GET1^DIQ(44,$PIECE(ECX,U),2,"I")
- +15 ;144 cvw
- SET NCODE=$$GET1^DIQ(728.441,$PIECE(ECX,U,8),.01)
- +16 IF $SELECT((ECXPCF="A")&('ACF):1,(ECXPCF="I")&(ACF):1,1:0)
- QUIT
- +17 Begin DoDot:2
- +18 IF PSC=""
- SET STR="Missing primary code"
- DO PRN
- QUIT
- +19 DO SCCHK(PSC,"P")
- IF $DATA(STR)
- DO PRN
- End DoDot:2
- IF ECXOUT
- QUIT
- +20 IF SSC'=""
- DO SCCHK(SSC,"S")
- IF $DATA(STR)
- DO PRN
- +21 Begin DoDot:2
- +22 ;I DPC="" S STR="No DSS primary code" D PRN Q ;154
- +23 ;I DPC'=PSC D SCCHK(DPC,"P") I $D(STR) D PRN
- End DoDot:2
- IF ECXOUT
- QUIT
- +24 ;I DSC'="",DSC'=SSC D SCCHK(DSC,"S") I $D(STR) D PRN
- +25 ;144 cvw
- Begin DoDot:2
- +26 ;144,149 cvw
- IF ($PIECE(ECX,U,8)'="")&(NCODE="")
- SET NCODE=$PIECE(ECX,U,8)
- SET STR="CHAR4 Code invalid"
- DO PRN
- QUIT
- +27 ;144,149 cvw
- IF $$GET1^DIQ(728.441,$PIECE(ECX,U,8),3)'=""
- SET STR="CHAR4 Code inactive"
- DO PRN
- QUIT
- End DoDot:2
- IF ECXOUT
- QUIT
- End DoDot:1
- if ECXOUT
- QUIT
- if ECXF
- SET CNTX=CNTX+1
- +28 ;144
- IF '$GET(ECXPORT)
- WRITE !!,?25,$SELECT(CNTX:CNTX,1:"NO")_" PROBLEM CLINICS FOUND."
- +29 QUIT
- PRN ;print line
- +1 if CLNF
- QUIT
- IF HTYP'="C"
- SET STR="Not a Clinic"
- SET CLNF=1
- +2 ;154
- IF $GET(ECXPORT)
- SET ^TMP($JOB,"ECXPORT",CNT)=IEN_"^"_NAM_"^"_PSC_"^"_SSC_"^"_NCODE_"^"_STR
- SET CNT=CNT+1
- QUIT
- +3 IF ($Y+3)>IOSL
- DO PAGE
- DO HDR
- IF ECXOUT
- QUIT
- +4 ;CVW 149
- WRITE !,IEN,?14,$EXTRACT(NAM,1,24),?48,PSC,?58,SSC,?75,NCODE,?91,STR
- +5 SET ECXF=1
- +6 QUIT
- +7 ;
- SCCHK(SCIEN,TYP) ;check stop code against file 40.7
- +1 NEW SCN,RTY,CTY,SCI,INACT,ARRY,I,FLG
- +2 KILL STR
- +3 SET CTY=$SELECT(TYP="P":"^P^E^",1:"^S^E^")
- +4 DO SCIEN(SCIEN)
- IF SCI=""
- Begin DoDot:1
- +5 ;S SCI=$$SCIEN(SCIEN) I SCI="" D Q
- +6 IF TYP="S"
- if SSC=PSC
- QUIT
- if DSC=DPC
- QUIT
- +7 SET STR=SCIEN_" Invalid Stop Code"
- End DoDot:1
- QUIT
- +8 SET SCN=$GET(^DIC(40.7,SCI,0))
- SET RTY=$PIECE(SCN,U,6)
- SET INACT=$PIECE(SCN,U,3)
- +9 IF INACT
- Begin DoDot:1
- +10 IF INACT>DT
- SET STR=SCIEN_" Inactive in future"
- +11 IF '$TEST
- SET STR=SCIEN_" Code is inactive"
- End DoDot:1
- QUIT
- +12 IF $PIECE(SCN,U,2)=""
- SET STR="No pointer in file #40.7"
- QUIT
- +13 IF RTY=""
- SET STR=SCIEN_" No restriction type"
- QUIT
- +14 IF CTY'[("^"_RTY_"^")
- Begin DoDot:1
- +15 SET STR=SCIEN_" Cannot be "_$SELECT(TYP="P":"prim",1:"second")_"ary"
- End DoDot:1
- +16 QUIT
- 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 ECXOUT=1
- End DoDot:1
- +5 QUIT
- +6 ;
- SCIEN(SCIEN) ;Get stop code IEN
- +1 IF SCIEN=""
- QUIT ""
- +2 ;S SCIEN=$O(^DIC(40.7,"C",SCIEN,0))
- +3 ;Q SCIEN
- +4 ;find active code if one
- +5 SET SCI=$ORDER(^DIC(40.7,"C",SCIEN,0))
- +6 IF $ORDER(^DIC(40.7,"C",SCIEN,SCI))'>0
- QUIT
- +7 ;must be some duplicates so find the best one
- +8 SET I=""
- +9 FOR
- SET I=$ORDER(^DIC(40.7,"C",SCIEN,I))
- if 'I
- QUIT
- Begin DoDot:1
- +10 if '$DATA(^DIC(40.7,I,0))
- QUIT
- +11 SET INACT=$PIECE(^DIC(40.7,I,0),"^",3)
- SET FLG="A"
- Begin DoDot:2
- +12 IF INACT
- IF ((DT>INACT)!(DT=INACT))
- SET FLG="I"
- End DoDot:2
- +13 SET ARRY(FLG,I)=""
- End DoDot:1
- +14 IF $DATA(ARRY("A"))
- SET SCI=$ORDER(ARRY("A",0))
- +15 QUIT SCIEN
- +16 ;
- HDR ;header for data from file #728.44
- +1 WRITE @IOF
- +2 WRITE ECXRDT,?73,"Page: ",ECXPG,!
- +3 WRITE !,?18,"STOP CODE NON-CONFORMING CLINICS REPORT",!,?32
- +4 WRITE $SELECT(ECXPCF="A":"Active",ECXPCF="I":"Inactive",1:"All")_" Clinics",!
- +5 WRITE !,"CLINICS AND STOP CODES File (#728.44) - (Use 'Enter/Edit DSS "
- +6 WRITE "Stop Codes for",!,?25,"Clinics' [ECXSCEDIT] menu option to "
- +7 ;CVW 149
- WRITE "make corrections)",!!
- +8 WRITE "IEN #",?14,$SELECT(ECXPCF="B":"(*currently inactive)",1:"CLINIC NAME")
- +9 WRITE ?48,"STOP",?58,"CREDIT",?75,"CHAR4",?91,"REASON FOR NON-"
- +10 WRITE !,?48,"CODE",?58,"STOP CODE",?75,"CODE",?91,"CONFORMANCE"
- +11 WRITE !,$EXTRACT(LNS,1,132)
- +12 SET ECXPG=ECXPG+1
- +13 QUIT
