ECXPUTL.m

ECXPUTL ;ALB/GTS - Utilities for DSS Prosthetics Extract ;July 15, 1998

 ;;3.0;DSS EXTRACTS;**9,14**;Dec 22, 1997

 ;

PDIV() ; Prompt the user for a division and return its IEN

 ;

 ; Output:

 ;  ECXDIV

 ;     Successful  - Institution file IEN for the selected division

 ;   Unsuccessful  - 0

 ;

 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 S ECXDIV=0

 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions

 ;

 ;** If the user doesn't have divisions setup

 I 'ECDIVSXS DO

 .S DIR(0)="FAO^1:1"

 .S DIR("A",1)="You do not have any divisions defined in your user set up."

 .S DIR("A",2)="Contact an ADPAC or IRM for assistance."

 .S DIR("A")="Hit Return to continue."

 .D ^DIR K DIR,X,Y

 ;

 ;** If the user does have divisions setup

 I ECDIVSXS DO

 .S (ECDIVCT,ECDIVLP)=0

 .F  S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0)  DO

 ..I $D(^RMPR(669.9,"C",ECDIVLP)) S ECDIVCT=ECDIVCT+1

 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)

 .I 'ECDIVCT DO

 ..S DIR(0)="FAO^1:1"

 ..S DIR("A",1)="Your division is not set up as a prosthetic division."

 ..S DIR("A")="Hit Return to continue."

 ..D ^DIR K DIR,X,Y

 .I ECDIVCT=1 DO

 ..S ECXDIV=$O(ECTMP(""))

 ..K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"

 ..D EN^DIQ1 S ECXSNUM=$G(ECXDIC(4,DA,99,"I"))

 ..S ECXSNAME=$G(ECXDIC(4,DA,.01,"I"))

 ..K DIC,DIQ,DA,DR,ECXDIC

 ..I $L(ECXSNUM)>3 DO

 ...K ECTMP(ECXDIV)

 ...S DIR(0)="FAO^1:1"

 ...S DIR("A",1)="Your division ("_ECXSNUM_") is not a prosthetic primary division."

 ...S DIR("A",2)="Note that the Station Number ("_ECXSNUM_") is longer than 3 characters"

 ...S DIR("A",3)=" for the Station "_ECXSNAME_"."

 ...S DIR("A",4)="Check with IRM to identify the primary division and add it to your New Person"

 ...S DIR("A",5)=" file entry."

 ...S DIR("A")="Hit Return to continue."

 ...D ^DIR K DIR,X,Y

 ...S ECXDIV=0

 ..K ECXSNUM,ECXSNAME

 .I ECDIVCT>1 DO

 ..S DIC("A")="Select Prosthetic Division: ",DIC(0)="AEQM",DIC="^DIC(4,"

 ..S DIC("S")="I $D(ECTMP(+Y))&(+$L($P($G(^DIC(4,+Y,99)),""^"",1))=3)" D ^DIC

 ..I '$D(DTOUT),'$D(DUOUT),Y>0 S ECXDIV=+Y

 ..I $D(DTOUT)!($D(DUOUT))!(Y<1) DO

 ...S DIR(0)="FAO^1:1"

 ...S DIR("A",1)="You did not select a prosthetic division."

 ...S DIR("A")="Hit Return to continue."

 ...D ^DIR K DIR,X,Y

 ...S ECXDIV=0

 Q ECXDIV

 ;

PDIV2(DUZ) ; prompt user for any prosthetics division

 ; input

 ;  DUZ - ien in file #200

 ; Output:

 ;  ECXDIV

 ;     successful  - ien file #4^station number^station name

 ;   unsuccessful  - 0

 ;

 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 S ECXDIV=0

 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions

 ;If the user doesn't have divisions setup

 I 'ECDIVSXS D

 .S DIR(0)="FAO^1:1"

 .S DIR("A",1)="You do not have any divisions defined in your user set up."

 .S DIR("A",2)="Contact an ADPAC or IRM for assistance."

 .S DIR("A")="Hit Return to continue."

 .D ^DIR K DIR,X,Y

 ;If the user does have divisions setup

 I ECDIVSXS D

 .S (ECDIVCT,ECDIVLP)=0

 .F  S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0)  D

 ..I $D(^RMPR(669.9,"C",ECDIVLP)) S ECDIVCT=ECDIVCT+1

 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)

 .I 'ECDIVCT D

 ..S DIR(0)="FAO^1:1"

 ..S DIR("A",1)="Your division is not set up as a prosthetic division."

 ..S DIR("A")="Hit Return to continue."

 ..D ^DIR K DIR,X,Y

 .I ECDIVCT=1 D

 ..S ECXDIV=$O(ECTMP(""))

 ..K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"

 ..D EN^DIQ1

 ..S ECXDIV=ECXDIV_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))

 ..K DIC,DIQ,DA,DR,ECXDIC

 .I ECDIVCT>1 D

 ..S DIC("A")="Select Prosthetic Division: ",DIC(0)="AEQM",DIC="^DIC(4,"

 ..S DIC("S")="I $D(ECTMP(+Y))" D ^DIC

 ..I $D(DTOUT)!($D(DUOUT))!(Y<1) D  Q

 ...S DIR(0)="FAO^1:1"

 ...S DIR("A",1)="You did not select a prosthetic division."

 ...S DIR("A")="Hit Return to continue."

 ...D ^DIR K DIR,X,Y

 ...S ECXDIV=0

 ..I '$D(DTOUT),'$D(DUOUT),Y>0 S ECXDIV=+Y D  Q

 ...K ECXDIC S DA=ECXDIV,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99"

 ...D EN^DIQ1

 ...S ECXDIV=ECXDIV_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))

 ...K DIC,DIQ,DA,DR,ECXDIC

 Q ECXDIV

 ;

PDIV3(DUZ,PRIME,DIV) ; user divisions in primary prosthetics division

 ; input

 ;  DUZ   - ien in file #200 (required)

 ;  PRIME - primary division - ien file #4^station number^station name (required)

 ;  DIV   - array passed by reference (required)

 ; Output:

 ;  DIV   - array of 1 or more divisions associated with primary division

 ;     successful  - ien file #4^station number^station name

 ;   unsuccessful  - 0

 ;

 N ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 S DIV(1)=0

 S ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ) ;**Set up array of user divisions

 ;if the user doesn't have divisions setup

 I 'ECDIVSXS Q

 ;if the user does have divisions setup

 I ECDIVSXS D

 .S (ECDIVCT,ECDIVLP)=0

 .F  S ECDIVLP=$O(ECTMP(ECDIVLP)) Q:(+ECDIVLP=0)  D

 ..I '$D(^RMPR(669.9,"C",ECDIVLP)) K ECTMP(ECDIVLP)

 ..I $D(^RMPR(669.9,"C",ECDIVLP)) D

 ...S DA=ECDIVLP,DIC="^DIC(4,",DIQ(0)="I",DIQ="ECXDIC",DR=".01;99" D EN^DIQ1

 ...;does this division belong to primary division?

 ...I $E($G(ECXDIC(4,DA,99,"I")),1,3)'=$P(PRIME,U,2) K ECTMP(ECDIVLP) Q

 ...S ECDIVCT=ECDIVCT+1

 ...S DIV(ECDIVCT)=ECDIVLP_U_$G(ECXDIC(4,DA,99,"I"))_U_$G(ECXDIC(4,DA,.01,"I"))

 K DIC,DIQ,DA,DR,ECXDIC,X,Y

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---ECXPUTL   5380     printed  Mar 13, 2025@20:58:20                                                                                                                                                                                                     Page 2

ECXPUTL   ;ALB/GTS - Utilities for DSS Prosthetics Extract ;July 15, 1998

 +1       ;;3.0;DSS EXTRACTS;**9,14**;Dec 22, 1997

 +2       ;

PDIV()    ; Prompt the user for a division and return its IEN

 +1       ;

 +2       ; Output:

 +3       ;  ECXDIV

 +4       ;     Successful  - Institution file IEN for the selected division

 +5       ;   Unsuccessful  - 0

 +6       ;

 +7        NEW ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 +8        SET ECXDIV=0

 +9       ;**Set up array of user divisions

           SET ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ)

 +10      ;

 +11      ;** If the user doesn't have divisions setup

 +12       IF 'ECDIVSXS

               Begin DoDot:1

 +13               SET DIR(0)="FAO^1:1"

 +14               SET DIR("A",1)="You do not have any divisions defined in your user set up."

 +15               SET DIR("A",2)="Contact an ADPAC or IRM for assistance."

 +16               SET DIR("A")="Hit Return to continue."

 +17               DO ^DIR

                   KILL DIR,X,Y

               End DoDot:1

 +18      ;

 +19      ;** If the user does have divisions setup

 +20       IF ECDIVSXS

               Begin DoDot:1

 +21               SET (ECDIVCT,ECDIVLP)=0

 +22               FOR 

                       SET ECDIVLP=$ORDER(ECTMP(ECDIVLP))

                       if (+ECDIVLP=0)

                           QUIT 

                       Begin DoDot:2

 +23                       IF $DATA(^RMPR(669.9,"C",ECDIVLP))

                               SET ECDIVCT=ECDIVCT+1

 +24                       IF '$DATA(^RMPR(669.9,"C",ECDIVLP))

                               KILL ECTMP(ECDIVLP)

                       End DoDot:2

 +25               IF 'ECDIVCT

                       Begin DoDot:2

 +26                       SET DIR(0)="FAO^1:1"

 +27                       SET DIR("A",1)="Your division is not set up as a prosthetic division."

 +28                       SET DIR("A")="Hit Return to continue."

 +29                       DO ^DIR

                           KILL DIR,X,Y

                       End DoDot:2

 +30               IF ECDIVCT=1

                       Begin DoDot:2

 +31                       SET ECXDIV=$ORDER(ECTMP(""))

 +32                       KILL ECXDIC

                           SET DA=ECXDIV

                           SET DIC="^DIC(4,"

                           SET DIQ(0)="I"

                           SET DIQ="ECXDIC"

                           SET DR=".01;99"

 +33                       DO EN^DIQ1

                           SET ECXSNUM=$GET(ECXDIC(4,DA,99,"I"))

 +34                       SET ECXSNAME=$GET(ECXDIC(4,DA,.01,"I"))

 +35                       KILL DIC,DIQ,DA,DR,ECXDIC

 +36                       IF $LENGTH(ECXSNUM)>3

                               Begin DoDot:3

 +37                               KILL ECTMP(ECXDIV)

 +38                               SET DIR(0)="FAO^1:1"

 +39                               SET DIR("A",1)="Your division ("_ECXSNUM_") is not a prosthetic primary division."

 +40                               SET DIR("A",2)="Note that the Station Number ("_ECXSNUM_") is longer than 3 characters"

 +41                               SET DIR("A",3)=" for the Station "_ECXSNAME_"."

 +42                               SET DIR("A",4)="Check with IRM to identify the primary division and add it to your New Person"

 +43                               SET DIR("A",5)=" file entry."

 +44                               SET DIR("A")="Hit Return to continue."

 +45                               DO ^DIR

                                   KILL DIR,X,Y

 +46                               SET ECXDIV=0

                               End DoDot:3

 +47                       KILL ECXSNUM,ECXSNAME

                       End DoDot:2

 +48               IF ECDIVCT>1

                       Begin DoDot:2

 +49                       SET DIC("A")="Select Prosthetic Division: "

                           SET DIC(0)="AEQM"

                           SET DIC="^DIC(4,"

 +50                       SET DIC("S")="I $D(ECTMP(+Y))&(+$L($P($G(^DIC(4,+Y,99)),""^"",1))=3)"

                           DO ^DIC

 +51                       IF '$DATA(DTOUT)

                               IF '$DATA(DUOUT)

                                   IF Y>0

                                       SET ECXDIV=+Y

 +52                       IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<1)

                               Begin DoDot:3

 +53                               SET DIR(0)="FAO^1:1"

 +54                               SET DIR("A",1)="You did not select a prosthetic division."

 +55                               SET DIR("A")="Hit Return to continue."

 +56                               DO ^DIR

                                   KILL DIR,X,Y

 +57                               SET ECXDIV=0

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +58       QUIT ECXDIV

 +59      ;

PDIV2(DUZ) ; prompt user for any prosthetics division

 +1       ; input

 +2       ;  DUZ - ien in file #200

 +3       ; Output:

 +4       ;  ECXDIV

 +5       ;     successful  - ien file #4^station number^station name

 +6       ;   unsuccessful  - 0

 +7       ;

 +8        NEW ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 +9        SET ECXDIV=0

 +10      ;**Set up array of user divisions

           SET ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ)

 +11      ;If the user doesn't have divisions setup

 +12       IF 'ECDIVSXS

               Begin DoDot:1

 +13               SET DIR(0)="FAO^1:1"

 +14               SET DIR("A",1)="You do not have any divisions defined in your user set up."

 +15               SET DIR("A",2)="Contact an ADPAC or IRM for assistance."

 +16               SET DIR("A")="Hit Return to continue."

 +17               DO ^DIR

                   KILL DIR,X,Y

               End DoDot:1

 +18      ;If the user does have divisions setup

 +19       IF ECDIVSXS

               Begin DoDot:1

 +20               SET (ECDIVCT,ECDIVLP)=0

 +21               FOR 

                       SET ECDIVLP=$ORDER(ECTMP(ECDIVLP))

                       if (+ECDIVLP=0)

                           QUIT 

                       Begin DoDot:2

 +22                       IF $DATA(^RMPR(669.9,"C",ECDIVLP))

                               SET ECDIVCT=ECDIVCT+1

 +23                       IF '$DATA(^RMPR(669.9,"C",ECDIVLP))

                               KILL ECTMP(ECDIVLP)

                       End DoDot:2

 +24               IF 'ECDIVCT

                       Begin DoDot:2

 +25                       SET DIR(0)="FAO^1:1"

 +26                       SET DIR("A",1)="Your division is not set up as a prosthetic division."

 +27                       SET DIR("A")="Hit Return to continue."

 +28                       DO ^DIR

                           KILL DIR,X,Y

                       End DoDot:2

 +29               IF ECDIVCT=1

                       Begin DoDot:2

 +30                       SET ECXDIV=$ORDER(ECTMP(""))

 +31                       KILL ECXDIC

                           SET DA=ECXDIV

                           SET DIC="^DIC(4,"

                           SET DIQ(0)="I"

                           SET DIQ="ECXDIC"

                           SET DR=".01;99"

 +32                       DO EN^DIQ1

 +33                       SET ECXDIV=ECXDIV_U_$GET(ECXDIC(4,DA,99,"I"))_U_$GET(ECXDIC(4,DA,.01,"I"))

 +34                       KILL DIC,DIQ,DA,DR,ECXDIC

                       End DoDot:2

 +35               IF ECDIVCT>1

                       Begin DoDot:2

 +36                       SET DIC("A")="Select Prosthetic Division: "

                           SET DIC(0)="AEQM"

                           SET DIC="^DIC(4,"

 +37                       SET DIC("S")="I $D(ECTMP(+Y))"

                           DO ^DIC

 +38                       IF $DATA(DTOUT)!($DATA(DUOUT))!(Y<1)

                               Begin DoDot:3

 +39                               SET DIR(0)="FAO^1:1"

 +40                               SET DIR("A",1)="You did not select a prosthetic division."

 +41                               SET DIR("A")="Hit Return to continue."

 +42                               DO ^DIR

                                   KILL DIR,X,Y

 +43                               SET ECXDIV=0

                               End DoDot:3

                               QUIT 

 +44                       IF '$DATA(DTOUT)

                               IF '$DATA(DUOUT)

                                   IF Y>0

                                       SET ECXDIV=+Y

                                       Begin DoDot:3

 +45                                       KILL ECXDIC

                                           SET DA=ECXDIV

                                           SET DIC="^DIC(4,"

                                           SET DIQ(0)="I"

                                           SET DIQ="ECXDIC"

                                           SET DR=".01;99"

 +46                                       DO EN^DIQ1

 +47                                       SET ECXDIV=ECXDIV_U_$GET(ECXDIC(4,DA,99,"I"))_U_$GET(ECXDIC(4,DA,.01,"I"))

 +48                                       KILL DIC,DIQ,DA,DR,ECXDIC

                                       End DoDot:3

                                       QUIT 

                       End DoDot:2

               End DoDot:1

 +49       QUIT ECXDIV

 +50      ;

PDIV3(DUZ,PRIME,DIV) ; user divisions in primary prosthetics division

 +1       ; input

 +2       ;  DUZ   - ien in file #200 (required)

 +3       ;  PRIME - primary division - ien file #4^station number^station name (required)

 +4       ;  DIV   - array passed by reference (required)

 +5       ; Output:

 +6       ;  DIV   - array of 1 or more divisions associated with primary division

 +7       ;     successful  - ien file #4^station number^station name

 +8       ;   unsuccessful  - 0

 +9       ;

 +10       NEW ECXDIV,ECTMP,ECDIVCT,ECDIVSXS,ECDIVLP

 +11       SET DIV(1)=0

 +12      ;**Set up array of user divisions

           SET ECDIVSXS=$$DIV4^XUSER(.ECTMP,DUZ)

 +13      ;if the user doesn't have divisions setup

 +14       IF 'ECDIVSXS

               QUIT 

 +15      ;if the user does have divisions setup

 +16       IF ECDIVSXS

               Begin DoDot:1

 +17               SET (ECDIVCT,ECDIVLP)=0

 +18               FOR 

                       SET ECDIVLP=$ORDER(ECTMP(ECDIVLP))

                       if (+ECDIVLP=0)

                           QUIT 

                       Begin DoDot:2

 +19                       IF '$DATA(^RMPR(669.9,"C",ECDIVLP))

                               KILL ECTMP(ECDIVLP)

 +20                       IF $DATA(^RMPR(669.9,"C",ECDIVLP))

                               Begin DoDot:3

 +21                               SET DA=ECDIVLP

                                   SET DIC="^DIC(4,"

                                   SET DIQ(0)="I"

                                   SET DIQ="ECXDIC"

                                   SET DR=".01;99"

                                   DO EN^DIQ1

 +22      ;does this division belong to primary division?

 +23                               IF $EXTRACT($GET(ECXDIC(4,DA,99,"I")),1,3)'=$PIECE(PRIME,U,2)

                                       KILL ECTMP(ECDIVLP)

                                       QUIT 

 +24                               SET ECDIVCT=ECDIVCT+1

 +25                               SET DIV(ECDIVCT)=ECDIVLP_U_$GET(ECXDIC(4,DA,99,"I"))_U_$GET(ECXDIC(4,DA,.01,"I"))

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +26       KILL DIC,DIQ,DA,DR,ECXDIC,X,Y

 +27       QUIT