- ORLP1 ; SLC/DCM,CLA - Patient Lists, Store ; 1/19/11 10:12am
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,63,90,98,273**;Dec 17, 1997;Build 17
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;DBIA reference section
- ;2160 - ^XUTL("OR"
- ;10006 - DIC
- ;10009 - YN^DICN
- ;10018 - DIE
- ;10013 - DIK
- ;10026 - DIR
- ;2957 - CLNLIST^GMRCTU
- ;2263 - XPAR
- ;
- STOR ;called by ORLP0 - Store lists
- N %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
- W !!,"Store list for future reference"
- S %=1 D YN^DICN Q:%=-1
- I %=0 W !,"You may store the newly compiled list. Answer YES or NO." G STOR
- Q:%=2
- ;
- GETNAME ; Call DIR to get user entry for new list name:
- N ORTNAM
- S ORTNAM=""
- N ORNEWL ; Flag used to indicate a new list (v. existing list).
- S ORNEWL=1 ; Begin w/assumption of a new list name.
- F D Q:$D(X)
- .S DIR(0)="FAO^3:30",DIR("A")="Enter a name for this list: "
- .D ^DIR
- .I '$D(X)!($D(DIRUT)) K DIRUT W " List not permanently stored." Q
- .S (ORLN,ORTNAM)=X
- .S X=$G(X),DIC="^OR(100.21,"
- .D ^DIC
- I '$D(X)!(X="") Q
- I +Y>0 S ORLIST=+Y,ORLN=$P(Y,U,2) K DIC S Y=ORLIST S ORNEWL=0 ; List name already exists.
- ;
- OVRWR ;
- N ORABORT ; Flag for aborting process.
- N ERROR
- S ORABORT=0
- ;
- ; Check for problems with name entry:
- I 'ORNEWL D
- .I $$NAMCH(+ORLIST) S ORABORT=1
- I ORABORT G GETNAME
- ;
- ; Ask - overwrite if an existing team by that name already?:
- I 'ORNEWL D Q:$G(ERROR)
- .I $O(^OR(100.21,+Y,10,0)) D Q:%'=1 ; Any patients on list yet?
- ..F D Q:%
- ...W !,ORLN_" already has patients. Do you want to overwrite it"
- ...S %=2 D YN^DICN
- ...I %=2!(%=-1) W !,"List ",ORLN," unchanged.",! S ORABORT=1 Q
- ...I '% W !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",! Q
- .I ORABORT Q
- .L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." S ERROR=1 Q
- .I '$D(^OR(100.21,ORLIST,10,0))#2 S ^(0)="^100.2101AV^"
- .I '$D(^OR(100.21,ORLIST,1,0))#2 S ^(0)="^100.212PA^"
- .S I=0 F S I=$O(^OR(100.21,ORLIST,10,I)) Q:'I S DA=+I,DA(1)=+ORLIST,DIK="^OR(100.21,"_ORLIST_",10," D ^DIK
- .L -^OR(100.21,+ORLIST)
- I ORABORT G GETNAME
- ;
- ; If a new list name, write new team into OE/RR LIST file:
- I ORNEWL D
- .S DIC="^OR(100.21,",DLAYGO=100.21,DIC(0)="LEFQZ"
- .D ^DIC
- .I (Y<0!'$D(X)) S ORABORT=1 Q ; User aborted or there was a problem.
- .S ORLIST=+Y
- I ORABORT K DIC Q
- ;
- ; Assure other required entries if necessary:
- I ORNEWL D
- .I $P($G(^OR(100.21,+ORLIST,1,0)),U,2)'="P" D
- ..S DIE="^OR(100.21,",DA=ORLIST,DR="1///^S X=""P"""
- ..D ^DIE
- ..K DIE,DA
- .I '$D(^OR(100.21,+ORLIST,1,DUZ)) S DA(1)=ORLIST,DIC="^OR(100.21,"_DA(1)_",1,",DIC(0)="LX",X="`"_DUZ D ^DIC K DIC
- ;
- ; Add selected patients to list (if any):
- L +^OR(100.21,+ORLIST):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
- S ORI=0
- F S ORI=$O(^XUTL("OR",$J,"ORLP",ORI)) Q:ORI<1 I $D(^(ORI,0)) S X=^(0),X="PT.`"_+$P(X,"^",3),DA(1)=ORLIST,DIC="^OR(100.21,"_ORLIST_",10,",DIC(0)="LX" D ^DIC
- K DIC,ORI
- L -^OR(100.21,ORLIST)
- W !!,"List has been stored."
- Q
- ;
- MERG ;called by option ORLP MERG - merge patient lists
- D CLEAR^ORLP ;clear XUTL for merge
- D ASK^ORLP0(.X)
- I (X<0)!(X>1) Q
- S:'$D(ORCNT) ORCNT=0
- W @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
- S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I ""PT""[$E($P(^(0),U,2))"
- F ORK=1:1 S ORCT=0,DIC("A")="Select LIST "_ORK_": " D P1^ORLP0 Q:ORY<1 I ORCNT>0 W !!,ORCT_" Patients added, "_ORCNT_" total"
- Q:$D(DTOUT)!($D(DUOUT))
- I 'ORCNT W !!,"List empty.",! D END^ORLP0 Q
- D PR2^ORLA1(OROPREF)
- W !!,"LIST PATIENTS MERGED"
- D LIST^ORLP0
- D STOR,END^ORLP0
- D BUILD^ORLA1 ;load XUTL with user's primary list
- K DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
- Q
- ;
- DEL ;called by option ORLP DELETE - delete a list
- I '$D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)'=""P""",DIC("A")="Select Team PATIENT LIST to delete: "
- I $D(ORLST) S DIC="^OR(100.21,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,2)=""P""&($D(^OR(100.21,""C"",DUZ,+Y)))",DIC("A")="Select Personal PATIENT LIST to delete: "
- D ^DIC
- K DIC
- I Y<1 Q
- S ORPTEAM=Y
- ;
- D2 ;
- S %=""
- I $$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")=+ORPTEAM W !!,"This is your primary patient list, are you sure you want to remove it" S %=2 D YN^DICN
- I %=0 W !,"Answer YES if you really want to remove this list." G D2
- I %'="" Q:%'=1
- W !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
- ;
- D1 ;
- L +^OR(100.21,+ORPTEAM):$G(DILOCKTM,3) I '$T W !,"Another user is editing this entry." Q
- W !,"Are you ready to delete list ",$P(ORPTEAM,"^",2)
- S %=2 D YN^DICN
- I %=0 W !,"Enter YES to delete the list, NO to quit." G D1
- Q:%'=1
- W !,"Processing........"
- ;L +^OR(100.21,+ORPTEAM)
- S DA=+ORPTEAM,DIK="^OR(100.21,"
- D ^DIK
- K DA,DIC,DIK
- ;
- ; Next 2 lines added by PKS, 2/8/2000:
- W !,"Searching for/removing Consults pointers to deleted team..."
- D CLNLIST^GMRCTU(+ORPTEAM,0) ; Dump pointers to team in file 123.5.
- ;
- W !,"List deletion completed.",!
- L -^OR(100.21,+ORPTEAM)
- K ORPTEAM,ORLPDUZ,Y,XX,^TMP("ORLP",$J,"TLIST") ;KILL temporary list
- G DEL
- Q
- ;
- CLEAR(X) ;called by option ORLP CLEAR - clear active list
- I '$D(^XUTL("OR",$J,"ORLP")) W !!,"No list currently defined" S X=1 Q
- F D Q:X
- . W !!,"Are you sure you want to clear the current pt selection list"
- . S %=2 D YN^DICN
- . I %=-1 S X=% Q
- . I %=0 W !!,"YES will clear the current pt selection list and leave you with a blank slate to work from." S X=0 Q
- . I %=1 K ^XUTL("OR",$J,"ORLP"),^("ORV"),^("ORU"),^("ORW") S:$D(ORCNT) ORCNT=0 W !!,"List cleared" S X=% Q
- . W !!,"Nothing done."
- . S X=2
- Q
- ;
- NAMCH(ORTEAM) ; Check for name duplication, proper team type.
- ;
- ; Variables used:
- ;
- ; ORTEAM = IEN of team in Team List file (^OR100.21).
- ;
- ; Check for name duplication and not a "Personal" type team:
- I $P($G(^OR(100.21,ORTEAM,0)),U,2)'="P" D Q 1
- .W !,ORTNAM," name already used - can't overwrite.",!
- .K X,Y,ORLIST,ORLN
- ;
- ; Check for "Personal" type but not current user's team:
- ; ("CREATOR" field was added later, so not used here.)
- ; Is this user's DUZ in "USER" multiple?
- I '$D(^OR(100.21,"C",DUZ,ORTEAM)) D Q 1
- .W !,ORTNAM," name exists, you are not a user - can't overwrite.",!
- .K X,Y,ORLIST,ORLN
- ;
- Q 0
- ;
- OWNER ; Get input from CAC for list user/owner.
- ;
- ; Variables used herein:
- ;
- ; DIR,X,Y = FM call variables.
- ; ORYY = NEW'd in calling routine (ORLP).
- ; OROWNER = NEW'd in calling routine (ORLP).
- ;
- N DIR,X,Y
- ;
- ; Assign variables and get input from CAC for user/owner of list:
- S OROWNER="" ; Default.
- S DIR(0)="PAO^200,:AEMNQ"
- S DIR("A")=" Enter owner of this Personal type list: "
- S DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
- S DIR("?")="Only owner you specify can edit list after creation."
- D ^DIR
- S OROWNER=Y
- K DIR,X,Y ; Clean up.
- I OROWNER<1 S OROWNER="" Q ; No acceptable entry.
- S OROWNER=+OROWNER ; Selected user's DUZ.
- S $P(^OR(100.21,+ORYY,0),U,5)=OROWNER ; Assign CREATOR field.
- ;
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORLP1 7421 printed Jan 18, 2025@03:32:30 Page 2
- ORLP1 ; SLC/DCM,CLA - Patient Lists, Store ; 1/19/11 10:12am
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**11,63,90,98,273**;Dec 17, 1997;Build 17
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;DBIA reference section
- +5 ;2160 - ^XUTL("OR"
- +6 ;10006 - DIC
- +7 ;10009 - YN^DICN
- +8 ;10018 - DIE
- +9 ;10013 - DIK
- +10 ;10026 - DIR
- +11 ;2957 - CLNLIST^GMRCTU
- +12 ;2263 - XPAR
- +13 ;
- STOR ;called by ORLP0 - Store lists
- +1 NEW %,DA,DIC,DIK,DIR,DLAYGO,DR,ORLIST,ORLN,I,J,X,Y
- +2 WRITE !!,"Store list for future reference"
- +3 SET %=1
- DO YN^DICN
- if %=-1
- QUIT
- +4 IF %=0
- WRITE !,"You may store the newly compiled list. Answer YES or NO."
- GOTO STOR
- +5 if %=2
- QUIT
- +6 ;
- GETNAME ; Call DIR to get user entry for new list name:
- +1 NEW ORTNAM
- +2 SET ORTNAM=""
- +3 ; Flag used to indicate a new list (v. existing list).
- NEW ORNEWL
- +4 ; Begin w/assumption of a new list name.
- SET ORNEWL=1
- +5 FOR
- Begin DoDot:1
- +6 SET DIR(0)="FAO^3:30"
- SET DIR("A")="Enter a name for this list: "
- +7 DO ^DIR
- +8 IF '$DATA(X)!($DATA(DIRUT))
- KILL DIRUT
- WRITE " List not permanently stored."
- QUIT
- +9 SET (ORLN,ORTNAM)=X
- +10 SET X=$GET(X)
- SET DIC="^OR(100.21,"
- +11 DO ^DIC
- End DoDot:1
- if $DATA(X)
- QUIT
- +12 IF '$DATA(X)!(X="")
- QUIT
- +13 ; List name already exists.
- IF +Y>0
- SET ORLIST=+Y
- SET ORLN=$PIECE(Y,U,2)
- KILL DIC
- SET Y=ORLIST
- SET ORNEWL=0
- +14 ;
- OVRWR ;
- +1 ; Flag for aborting process.
- NEW ORABORT
- +2 NEW ERROR
- +3 SET ORABORT=0
- +4 ;
- +5 ; Check for problems with name entry:
- +6 IF 'ORNEWL
- Begin DoDot:1
- +7 IF $$NAMCH(+ORLIST)
- SET ORABORT=1
- End DoDot:1
- +8 IF ORABORT
- GOTO GETNAME
- +9 ;
- +10 ; Ask - overwrite if an existing team by that name already?:
- +11 IF 'ORNEWL
- Begin DoDot:1
- +12 ; Any patients on list yet?
- IF $ORDER(^OR(100.21,+Y,10,0))
- Begin DoDot:2
- +13 FOR
- Begin DoDot:3
- +14 WRITE !,ORLN_" already has patients. Do you want to overwrite it"
- +15 SET %=2
- DO YN^DICN
- +16 IF %=2!(%=-1)
- WRITE !,"List ",ORLN," unchanged.",!
- SET ORABORT=1
- QUIT
- +17 IF '%
- WRITE !,"Answer YES or NO, if you answer YES the list "_ORLN_" will be cleared,",!,"and this temporary list will overwrite it.",!
- QUIT
- End DoDot:3
- if %
- QUIT
- End DoDot:2
- if %'=1
- QUIT
- +18 IF ORABORT
- QUIT
- +19 LOCK +^OR(100.21,+ORLIST):$GET(DILOCKTM,3)
- IF '$TEST
- WRITE !,"Another user is editing this entry."
- SET ERROR=1
- QUIT
- +20 IF '$DATA(^OR(100.21,ORLIST,10,0))#2
- SET ^(0)="^100.2101AV^"
- +21 IF '$DATA(^OR(100.21,ORLIST,1,0))#2
- SET ^(0)="^100.212PA^"
- +22 SET I=0
- FOR
- SET I=$ORDER(^OR(100.21,ORLIST,10,I))
- if 'I
- QUIT
- SET DA=+I
- SET DA(1)=+ORLIST
- SET DIK="^OR(100.21,"_ORLIST_",10,"
- DO ^DIK
- +23 LOCK -^OR(100.21,+ORLIST)
- End DoDot:1
- if $GET(ERROR)
- QUIT
- +24 IF ORABORT
- GOTO GETNAME
- +25 ;
- +26 ; If a new list name, write new team into OE/RR LIST file:
- +27 IF ORNEWL
- Begin DoDot:1
- +28 SET DIC="^OR(100.21,"
- SET DLAYGO=100.21
- SET DIC(0)="LEFQZ"
- +29 DO ^DIC
- +30 ; User aborted or there was a problem.
- IF (Y<0!'$DATA(X))
- SET ORABORT=1
- QUIT
- +31 SET ORLIST=+Y
- End DoDot:1
- +32 IF ORABORT
- KILL DIC
- QUIT
- +33 ;
- +34 ; Assure other required entries if necessary:
- +35 IF ORNEWL
- Begin DoDot:1
- +36 IF $PIECE($GET(^OR(100.21,+ORLIST,1,0)),U,2)'="P"
- Begin DoDot:2
- +37 SET DIE="^OR(100.21,"
- SET DA=ORLIST
- SET DR="1///^S X=""P"""
- +38 DO ^DIE
- +39 KILL DIE,DA
- End DoDot:2
- +40 IF '$DATA(^OR(100.21,+ORLIST,1,DUZ))
- SET DA(1)=ORLIST
- SET DIC="^OR(100.21,"_DA(1)_",1,"
- SET DIC(0)="LX"
- SET X="`"_DUZ
- DO ^DIC
- KILL DIC
- End DoDot:1
- +41 ;
- +42 ; Add selected patients to list (if any):
- +43 LOCK +^OR(100.21,+ORLIST):$GET(DILOCKTM,3)
- IF '$TEST
- WRITE !,"Another user is editing this entry."
- QUIT
- +44 SET ORI=0
- +45 FOR
- SET ORI=$ORDER(^XUTL("OR",$JOB,"ORLP",ORI))
- if ORI<1
- QUIT
- IF $DATA(^(ORI,0))
- SET X=^(0)
- SET X="PT.`"_+$PIECE(X,"^",3)
- SET DA(1)=ORLIST
- SET DIC="^OR(100.21,"_ORLIST_",10,"
- SET DIC(0)="LX"
- DO ^DIC
- +46 KILL DIC,ORI
- +47 LOCK -^OR(100.21,ORLIST)
- +48 WRITE !!,"List has been stored."
- +49 QUIT
- +50 ;
- MERG ;called by option ORLP MERG - merge patient lists
- +1 ;clear XUTL for merge
- DO CLEAR^ORLP
- +2 DO ASK^ORLP0(.X)
- +3 IF (X<0)!(X>1)
- QUIT
- +4 if '$DATA(ORCNT)
- SET ORCNT=0
- +5 WRITE @IOF,!,"Merging patients from two or more Personal and/or Team patient lists.",!
- +6 SET DIC="^OR(100.21,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I ""PT""[$E($P(^(0),U,2))"
- +7 FOR ORK=1:1
- SET ORCT=0
- SET DIC("A")="Select LIST "_ORK_": "
- DO P1^ORLP0
- if ORY<1
- QUIT
- IF ORCNT>0
- WRITE !!,ORCT_" Patients added, "_ORCNT_" total"
- +8 if $DATA(DTOUT)!($DATA(DUOUT))
- QUIT
- +9 IF 'ORCNT
- WRITE !!,"List empty.",!
- DO END^ORLP0
- QUIT
- +10 DO PR2^ORLA1(OROPREF)
- +11 WRITE !!,"LIST PATIENTS MERGED"
- +12 DO LIST^ORLP0
- +13 DO STOR
- DO END^ORLP0
- +14 ;load XUTL with user's primary list
- DO BUILD^ORLA1
- +15 KILL DIC,ORCEND,ORCLIN,ORCNT,ORCOLW,ORCSTRT,ORCT,ORDEF,ORK,ORPRIM,ORPROV,ORSPEC,ORTITLE,ORUPNM,ORUSSN,ORWARD,Y
- +16 QUIT
- +17 ;
- DEL ;called by option ORLP DELETE - delete a list
- +1 IF '$DATA(ORLST)
- SET DIC="^OR(100.21,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,2)'=""P"""
- SET DIC("A")="Select Team PATIENT LIST to delete: "
- +2 IF $DATA(ORLST)
- SET DIC="^OR(100.21,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,2)=""P""&($D(^OR(100.21,""C"",DUZ,+Y)))"
- SET DIC("A")="Select Personal PATIENT LIST to delete: "
- +3 DO ^DIC
- +4 KILL DIC
- +5 IF Y<1
- QUIT
- +6 SET ORPTEAM=Y
- +7 ;
- D2 ;
- +1 SET %=""
- +2 IF $$GET^XPAR("USR.`"_DUZ,"ORLP DEFAULT TEAM",1,"I")=+ORPTEAM
- WRITE !!,"This is your primary patient list, are you sure you want to remove it"
- SET %=2
- DO YN^DICN
- +3 IF %=0
- WRITE !,"Answer YES if you really want to remove this list."
- GOTO D2
- +4 IF %'=""
- if %'=1
- QUIT
- +5 WRITE !!,"WARNING - Deleting a patient list will disable access by providers who use the",!,"list as their preferred patient list."
- +6 ;
- D1 ;
- +1 LOCK +^OR(100.21,+ORPTEAM):$GET(DILOCKTM,3)
- IF '$TEST
- WRITE !,"Another user is editing this entry."
- QUIT
- +2 WRITE !,"Are you ready to delete list ",$PIECE(ORPTEAM,"^",2)
- +3 SET %=2
- DO YN^DICN
- +4 IF %=0
- WRITE !,"Enter YES to delete the list, NO to quit."
- GOTO D1
- +5 if %'=1
- QUIT
- +6 WRITE !,"Processing........"
- +7 ;L +^OR(100.21,+ORPTEAM)
- +8 SET DA=+ORPTEAM
- SET DIK="^OR(100.21,"
- +9 DO ^DIK
- +10 KILL DA,DIC,DIK
- +11 ;
- +12 ; Next 2 lines added by PKS, 2/8/2000:
- +13 WRITE !,"Searching for/removing Consults pointers to deleted team..."
- +14 ; Dump pointers to team in file 123.5.
- DO CLNLIST^GMRCTU(+ORPTEAM,0)
- +15 ;
- +16 WRITE !,"List deletion completed.",!
- +17 LOCK -^OR(100.21,+ORPTEAM)
- +18 ;KILL temporary list
- KILL ORPTEAM,ORLPDUZ,Y,XX,^TMP("ORLP",$JOB,"TLIST")
- +19 GOTO DEL
- +20 QUIT
- +21 ;
- CLEAR(X) ;called by option ORLP CLEAR - clear active list
- +1 IF '$DATA(^XUTL("OR",$JOB,"ORLP"))
- WRITE !!,"No list currently defined"
- SET X=1
- QUIT
- +2 FOR
- Begin DoDot:1
- +3 WRITE !!,"Are you sure you want to clear the current pt selection list"
- +4 SET %=2
- DO YN^DICN
- +5 IF %=-1
- SET X=%
- QUIT
- +6 IF %=0
- WRITE !!,"YES will clear the current pt selection list and leave you with a blank slate to work from."
- SET X=0
- QUIT
- +7 IF %=1
- KILL ^XUTL("OR",$JOB,"ORLP"),^("ORV"),^("ORU"),^("ORW")
- if $DATA(ORCNT)
- SET ORCNT=0
- WRITE !!,"List cleared"
- SET X=%
- QUIT
- +8 WRITE !!,"Nothing done."
- +9 SET X=2
- End DoDot:1
- if X
- QUIT
- +10 QUIT
- +11 ;
- NAMCH(ORTEAM) ; Check for name duplication, proper team type.
- +1 ;
- +2 ; Variables used:
- +3 ;
- +4 ; ORTEAM = IEN of team in Team List file (^OR100.21).
- +5 ;
- +6 ; Check for name duplication and not a "Personal" type team:
- +7 IF $PIECE($GET(^OR(100.21,ORTEAM,0)),U,2)'="P"
- Begin DoDot:1
- +8 WRITE !,ORTNAM," name already used - can't overwrite.",!
- +9 KILL X,Y,ORLIST,ORLN
- End DoDot:1
- QUIT 1
- +10 ;
- +11 ; Check for "Personal" type but not current user's team:
- +12 ; ("CREATOR" field was added later, so not used here.)
- +13 ; Is this user's DUZ in "USER" multiple?
- +14 IF '$DATA(^OR(100.21,"C",DUZ,ORTEAM))
- Begin DoDot:1
- +15 WRITE !,ORTNAM," name exists, you are not a user - can't overwrite.",!
- +16 KILL X,Y,ORLIST,ORLN
- End DoDot:1
- QUIT 1
- +17 ;
- +18 QUIT 0
- +19 ;
- OWNER ; Get input from CAC for list user/owner.
- +1 ;
- +2 ; Variables used herein:
- +3 ;
- +4 ; DIR,X,Y = FM call variables.
- +5 ; ORYY = NEW'd in calling routine (ORLP).
- +6 ; OROWNER = NEW'd in calling routine (ORLP).
- +7 ;
- +8 NEW DIR,X,Y
- +9 ;
- +10 ; Assign variables and get input from CAC for user/owner of list:
- +11 ; Default.
- SET OROWNER=""
- +12 SET DIR(0)="PAO^200,:AEMNQ"
- +13 SET DIR("A")=" Enter owner of this Personal type list: "
- +14 SET DIR("S")="I $D(X),$D(^VA(200,""AK.PROVIDER"",$P(^(0),U))),$$ACTIVE^XUSER(+Y)"
- +15 SET DIR("?")="Only owner you specify can edit list after creation."
- +16 DO ^DIR
- +17 SET OROWNER=Y
- +18 ; Clean up.
- KILL DIR,X,Y
- +19 ; No acceptable entry.
- IF OROWNER<1
- SET OROWNER=""
- QUIT
- +20 ; Selected user's DUZ.
- SET OROWNER=+OROWNER
- +21 ; Assign CREATOR field.
- SET $PIECE(^OR(100.21,+ORYY,0),U,5)=OROWNER
- +22 ;
- +23 QUIT
- +24 ;