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 ---[H[J[2J[HECXPUTL 5380 printed Nov 22, 2024@17:03:50 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
