- SCMCMU1 ;ALB/MJK - PCMM Mass Team/Position List Manager ; 10-JUL-1998
- ;;5.3;Scheduling;**148**;AUG 13, 1993
- ;
- EN(SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE) ; -- main entry point for SCMC MU MASS TEAM UNASSIGNMENT
- D EN^VALM("SCMC MU MASS TEAM UNASSIGNMENT")
- Q
- ;
- HDR ; -- header code
- N X,SCTEAM0
- S SCTEAM0=$G(^SCTM(404.51,+SCTEAM,0),"Unknown")
- S X=$E(" Team: "_$P(SCTEAM0,U),1,40)
- S X=$$SETSTR^VALM1(" Total: "_+$G(SCALLCNT)_" Selected: "_+$G(SCSELCNT),X,45,35)
- S VALMHDR(1)=X
- ;
- S X=""
- IF SCMUTYPE="P" D
- . S SCPOS0=$G(^SCTM(404.57,+SCPOS,0),"Unknown")
- . S X=$E("Position: "_$P(SCPOS0,U),1,40)
- . IF '$G(SCTPDIS(+SCPOS)) Q
- . S X=$$SETSTR^VALM1("Clinic: "_$P($G(^SC(+$P(SCPOS0,U,9),0),"Unknown"),U),X,45,35)
- .Q
- ;
- S VALMHDR(2)=X
- S X="Proposed Effective Date: "_$$FMTE^XLFDT($E(SCDATE,1,7),"5Z")
- S X=$$SETSTR^VALM1(" View: "_SCVIEW_$S(SCVIEW="ALL":"",1:"ED"),X,45,35)
- S VALMHDR(3)=X
- Q
- ;
- INIT ; -- init variables and list array
- N SCPATS,SCI,SCALPHA,SCX,SCDTE
- S SCPATS=$NA(^TMP("SCMU",$J,"PATIENTS"))
- S SCALPHA=$NA(^TMP("SCMU",$J,"PATS ALPHA"))
- K @SCPATS,@SCALPHA
- ;
- ; -- set up persistent structures
- S SCPTINFO=$NA(^TMP("SCMU",$J,"PATIENT INFO")) ; useful patient data
- S SCPTSEL=$NA(^TMP("SCMU",$J,"SELECTED")) ; patients selected
- S SCPTALL=$NA(^TMP("SCMU",$J,"PATIENT ALL")) ; listman data
- ;
- K @SCPTINFO,@SCPTSEL,@SCPTALL
- S (SCALLCNT,SCSELCNT,SCMSG)=0
- S SCVIEW="ALL"
- ;
- W ! D WAIT^DICD
- ;
- ; -- change title is appropriate
- IF SCMUTYPE="P" S VALM("TITLE")="Mass Position Unassignment"
- ;
- ; -- get patients
- D DATE(SCDATE,.SCDTE)
- IF SCMUTYPE="T",'$$PTTM^SCAPMC(SCTEAM,SCDTE,SCPATS) G INITQ
- IF SCMUTYPE="P",'$$PTTP^SCAPMC(SCPOS,SCDTE,SCPATS) G INITQ
- ;
- ; -- build list for display
- S SCI=0
- F S SCI=$O(@SCPATS@(SCI)) Q:'SCI D
- . S SCX=@SCPATS@(SCI)
- . S @SCALPHA@($P(SCX,U,2)_SCI)=SCI
- . Q
- ;
- S SCNT=0
- S SCI=""
- F S SCI=$O(@SCALPHA@(SCI)) Q:SCI="" D
- . S SCX=$G(@SCPATS@(+@SCALPHA@(SCI)))
- . IF '$$FILTER(SCX,SCDATE) Q
- . S SCNT=SCNT+1
- . S Y=$$SETSTR^VALM1(SCNT,"",1,4) ; number
- . S Y=$$SETSTR^VALM1($P(SCX,U,2),Y,15,25) ; pt name
- . S Y=$$SETSTR^VALM1($P(SCX,U,6),Y,42,12) ; pt id
- . S Y=$$SETSTR^VALM1($$FMTE^XLFDT($P(SCX,U,4),"5Z"),Y,56,10) ; assigned
- . S Y=$$SETSTR^VALM1($$FMTE^XLFDT($P(SCX,U,5),"5Z"),Y,69,10) ; unassigned
- . ;
- . ; -- flag if this is a future assignment
- . IF $P(SCX,U,4)>DT D
- . . S Y=$$SETSTR^VALM1("*",Y,55,1)
- . . IF 'SCMSG S SCMSG=1 D MSG
- . ;
- . ; -- flag if this is a future unassignment
- . IF $P(SCX,U,5)>DT D
- . . S Y=$$SETSTR^VALM1("*",Y,68,1)
- . . IF 'SCMSG S SCMSG=1 D MSG
- . ;
- . S @SCPTALL@(SCNT,0)=Y
- . S @SCPTALL@("IDX",SCNT,SCNT)=SCNT
- . S @SCPTINFO@(SCNT)=SCX
- . Q
- K @SCPATS,@SCALPHA
- S SCALLCNT=SCNT
- ;
- ; -- set up lm array
- D BLD
- ;
- INITQ Q
- ;
- FILTER(SCX,SCDATE) ; -- apply filter criteria
- N SCOK
- S SCOK=1
- ; -- if inactivation date is =< effective then don't use
- IF $P(SCX,U,5),$P(SCX,U,5)'>SCDATE S SCOK=0
- Q SCOK
- ;
- BLD ; -- build VALMAR
- K @VALMAR
- ;
- IF SCVIEW="ALL" D
- . M @VALMAR=@SCPTALL
- . S VALMCNT=SCALLCNT
- . Q
- ;
- ELSE D
- . N SCNT
- . S (SCNT,VALMCNT)=0
- . F S SCNT=$O(@SCPTALL@(SCNT)) Q:'SCNT D
- . . ; -- if in select view and patient not selected then don't use
- . . IF SCVIEW="SELECT",'$D(@SCPTSEL@(SCNT)) Q
- . . ; -- if in de-select view and patient selected then don't use
- . . IF SCVIEW="DE-SELECT",$D(@SCPTSEL@(SCNT)) Q
- . . ;
- . . S VALMCNT=VALMCNT+1
- . . S Y=@SCPTALL@(SCNT,0)
- . . S @VALMAR@(VALMCNT,0)=$$SETSTR^VALM1(VALMCNT,Y,1,4)
- . . ;
- . . ; -- set idx to pointer back to SCPTALL (this is key!)
- . . S @VALMAR@("IDX",VALMCNT,VALMCNT)=SCNT
- . . Q
- . Q
- ;
- IF '$O(@VALMAR@(0)) D
- . S @VALMAR@(1,0)=" "
- . S @VALMAR@(2,0)=" "
- . S @VALMAR@(3,0)=" No patients to list."
- . Q
- IF $G(VALMBG),'$D(@VALMAR@(VALMBG,0)) S VALMBG=1
- K VALMHDR
- D BACK("R")
- Q
- ;
- SETSEL(FLAG,SCNT) ; -- set selected flag indicator
- N Y,SCPTCNT
- ;
- ; -- get pointer back to SCPTALL
- S SCPTCNT=+$G(@VALMAR@("IDX",SCNT,SCNT))
- IF FLAG="DE-SELECT",$D(@SCPTSEL@(SCPTCNT)) D
- . K @SCPTSEL@(SCPTCNT)
- . S SCSELCNT=$S(SCSELCNT=0:0,1:SCSELCNT-1)
- ;
- IF FLAG="SELECT",'$D(@SCPTSEL@(SCPTCNT)) D
- . S @SCPTSEL@(SCPTCNT)=""
- . S SCSELCNT=$S(SCSELCNT=SCALLCNT:SCALLCNT,1:SCSELCNT+1)
- ;
- S Y=$G(@VALMAR@(SCNT,0))
- S Y=$$SETSTR^VALM1($S(FLAG="SELECT":"Yes",1:""),Y,8,3)
- S @VALMAR@(SCNT,0)=Y
- ;
- ; -- need to do SCPTALL separately because of potential for differnt #'s
- S Y=$G(@SCPTALL@(SCPTCNT,0))
- S Y=$$SETSTR^VALM1($S(FLAG="SELECT":"Yes",1:""),Y,8,3)
- S @SCPTALL@(SCPTCNT,0)=Y
- Q
- ;
- HELP ; -- help code
- S X="?" D DISP^XQORM1 W !!
- Q
- ;
- EXIT ; -- exit code
- D CLEAR^VALM1
- K @VALMAR,SCSELCNT,SCVIEW,SCALLCNT,SCMSG
- K @SCPTALL,@SCPTSEL,@SCPTINFO
- K SCPTALL,SCPTSEL,SCPTINFO
- Q
- ;
- EXPND ; -- expand code
- Q
- ;
- ALL(SCACT) ; -- entry point for SCMC SELECT ALL & SCMC DESELECT ALL protocols
- IF SCVIEW=SCACT D Q
- . W !!,"All patients in current view are already '"_SCACT_"ED'."
- . D PAUSE
- . D BACK("")
- . Q
- D ACT(SCACT,SCPTALL)
- Q
- ;
- SOME(SCACT) ; -- entry point for SCMC SELECT SOME & SCMC DESELECT SOME protocols
- IF SCVIEW=SCACT D Q
- . W !!,"All patients in current view are already '"_SCACT_"ED'."
- . D PAUSE
- . D BACK("")
- . Q
- D EN^VALM2(XQORNOD(0),"O")
- D ACT(SCACT,"VALMY")
- Q
- ;
- ACT(SCACT,SCLIST) ; -- change select flag
- N SCNT
- S SCNT=0
- F S SCNT=$O(@SCLIST@(SCNT)) Q:'SCNT D SETSEL(SCACT,SCNT)
- W !
- D WAIT^DICD,BLD
- Q
- ;
- VIEW(SCVW) ; -- change view
- S SCVIEW=SCVW
- W !
- D WAIT^DICD,BLD
- Q
- ;
- BACK(ACTION) ; -- return to lm processing
- IF $G(SCMSG) D MSG
- S VALMBCK=ACTION
- Q
- ;
- MSG ; -- set message var
- S VALMSG="* Future date"
- Q
- ;
- DATE(SCDATE,SCDTE) ; -- setup date array
- S SCDTE="SCDTE"
- S SCDTE("BEGIN")=SCDATE
- S SCDTE("END")=9999999
- S SCDTE("INCL")=0
- Q
- ;
- PAUSE ; -- pause
- N DIR,Y
- S DIR(0)="EA"
- S DIR("A")="Enter RETURN to continue:"
- D ^DIR
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCMU1 6070 printed Jan 18, 2025@03:42:08 Page 2
- SCMCMU1 ;ALB/MJK - PCMM Mass Team/Position List Manager ; 10-JUL-1998
- +1 ;;5.3;Scheduling;**148**;AUG 13, 1993
- +2 ;
- EN(SCTEAM,SCPOS,SCTPDIS,SCMUTYPE,SCDATE) ; -- main entry point for SCMC MU MASS TEAM UNASSIGNMENT
- +1 DO EN^VALM("SCMC MU MASS TEAM UNASSIGNMENT")
- +2 QUIT
- +3 ;
- HDR ; -- header code
- +1 NEW X,SCTEAM0
- +2 SET SCTEAM0=$GET(^SCTM(404.51,+SCTEAM,0),"Unknown")
- +3 SET X=$EXTRACT(" Team: "_$PIECE(SCTEAM0,U),1,40)
- +4 SET X=$$SETSTR^VALM1(" Total: "_+$GET(SCALLCNT)_" Selected: "_+$GET(SCSELCNT),X,45,35)
- +5 SET VALMHDR(1)=X
- +6 ;
- +7 SET X=""
- +8 IF SCMUTYPE="P"
- Begin DoDot:1
- +9 SET SCPOS0=$GET(^SCTM(404.57,+SCPOS,0),"Unknown")
- +10 SET X=$EXTRACT("Position: "_$PIECE(SCPOS0,U),1,40)
- +11 IF '$GET(SCTPDIS(+SCPOS))
- QUIT
- +12 SET X=$$SETSTR^VALM1("Clinic: "_$PIECE($GET(^SC(+$PIECE(SCPOS0,U,9),0),"Unknown"),U),X,45,35)
- +13 QUIT
- End DoDot:1
- +14 ;
- +15 SET VALMHDR(2)=X
- +16 SET X="Proposed Effective Date: "_$$FMTE^XLFDT($EXTRACT(SCDATE,1,7),"5Z")
- +17 SET X=$$SETSTR^VALM1(" View: "_SCVIEW_$SELECT(SCVIEW="ALL":"",1:"ED"),X,45,35)
- +18 SET VALMHDR(3)=X
- +19 QUIT
- +20 ;
- INIT ; -- init variables and list array
- +1 NEW SCPATS,SCI,SCALPHA,SCX,SCDTE
- +2 SET SCPATS=$NAME(^TMP("SCMU",$JOB,"PATIENTS"))
- +3 SET SCALPHA=$NAME(^TMP("SCMU",$JOB,"PATS ALPHA"))
- +4 KILL @SCPATS,@SCALPHA
- +5 ;
- +6 ; -- set up persistent structures
- +7 ; useful patient data
- SET SCPTINFO=$NAME(^TMP("SCMU",$JOB,"PATIENT INFO"))
- +8 ; patients selected
- SET SCPTSEL=$NAME(^TMP("SCMU",$JOB,"SELECTED"))
- +9 ; listman data
- SET SCPTALL=$NAME(^TMP("SCMU",$JOB,"PATIENT ALL"))
- +10 ;
- +11 KILL @SCPTINFO,@SCPTSEL,@SCPTALL
- +12 SET (SCALLCNT,SCSELCNT,SCMSG)=0
- +13 SET SCVIEW="ALL"
- +14 ;
- +15 WRITE !
- DO WAIT^DICD
- +16 ;
- +17 ; -- change title is appropriate
- +18 IF SCMUTYPE="P"
- SET VALM("TITLE")="Mass Position Unassignment"
- +19 ;
- +20 ; -- get patients
- +21 DO DATE(SCDATE,.SCDTE)
- +22 IF SCMUTYPE="T"
- IF '$$PTTM^SCAPMC(SCTEAM,SCDTE,SCPATS)
- GOTO INITQ
- +23 IF SCMUTYPE="P"
- IF '$$PTTP^SCAPMC(SCPOS,SCDTE,SCPATS)
- GOTO INITQ
- +24 ;
- +25 ; -- build list for display
- +26 SET SCI=0
- +27 FOR
- SET SCI=$ORDER(@SCPATS@(SCI))
- if 'SCI
- QUIT
- Begin DoDot:1
- +28 SET SCX=@SCPATS@(SCI)
- +29 SET @SCALPHA@($PIECE(SCX,U,2)_SCI)=SCI
- +30 QUIT
- End DoDot:1
- +31 ;
- +32 SET SCNT=0
- +33 SET SCI=""
- +34 FOR
- SET SCI=$ORDER(@SCALPHA@(SCI))
- if SCI=""
- QUIT
- Begin DoDot:1
- +35 SET SCX=$GET(@SCPATS@(+@SCALPHA@(SCI)))
- +36 IF '$$FILTER(SCX,SCDATE)
- QUIT
- +37 SET SCNT=SCNT+1
- +38 ; number
- SET Y=$$SETSTR^VALM1(SCNT,"",1,4)
- +39 ; pt name
- SET Y=$$SETSTR^VALM1($PIECE(SCX,U,2),Y,15,25)
- +40 ; pt id
- SET Y=$$SETSTR^VALM1($PIECE(SCX,U,6),Y,42,12)
- +41 ; assigned
- SET Y=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(SCX,U,4),"5Z"),Y,56,10)
- +42 ; unassigned
- SET Y=$$SETSTR^VALM1($$FMTE^XLFDT($PIECE(SCX,U,5),"5Z"),Y,69,10)
- +43 ;
- +44 ; -- flag if this is a future assignment
- +45 IF $PIECE(SCX,U,4)>DT
- Begin DoDot:2
- +46 SET Y=$$SETSTR^VALM1("*",Y,55,1)
- +47 IF 'SCMSG
- SET SCMSG=1
- DO MSG
- End DoDot:2
- +48 ;
- +49 ; -- flag if this is a future unassignment
- +50 IF $PIECE(SCX,U,5)>DT
- Begin DoDot:2
- +51 SET Y=$$SETSTR^VALM1("*",Y,68,1)
- +52 IF 'SCMSG
- SET SCMSG=1
- DO MSG
- End DoDot:2
- +53 ;
- +54 SET @SCPTALL@(SCNT,0)=Y
- +55 SET @SCPTALL@("IDX",SCNT,SCNT)=SCNT
- +56 SET @SCPTINFO@(SCNT)=SCX
- +57 QUIT
- End DoDot:1
- +58 KILL @SCPATS,@SCALPHA
- +59 SET SCALLCNT=SCNT
- +60 ;
- +61 ; -- set up lm array
- +62 DO BLD
- +63 ;
- INITQ QUIT
- +1 ;
- FILTER(SCX,SCDATE) ; -- apply filter criteria
- +1 NEW SCOK
- +2 SET SCOK=1
- +3 ; -- if inactivation date is =< effective then don't use
- +4 IF $PIECE(SCX,U,5)
- IF $PIECE(SCX,U,5)'>SCDATE
- SET SCOK=0
- +5 QUIT SCOK
- +6 ;
- BLD ; -- build VALMAR
- +1 KILL @VALMAR
- +2 ;
- +3 IF SCVIEW="ALL"
- Begin DoDot:1
- +4 MERGE @VALMAR=@SCPTALL
- +5 SET VALMCNT=SCALLCNT
- +6 QUIT
- End DoDot:1
- +7 ;
- +8 IF '$TEST
- Begin DoDot:1
- +9 NEW SCNT
- +10 SET (SCNT,VALMCNT)=0
- +11 FOR
- SET SCNT=$ORDER(@SCPTALL@(SCNT))
- if 'SCNT
- QUIT
- Begin DoDot:2
- +12 ; -- if in select view and patient not selected then don't use
- +13 IF SCVIEW="SELECT"
- IF '$DATA(@SCPTSEL@(SCNT))
- QUIT
- +14 ; -- if in de-select view and patient selected then don't use
- +15 IF SCVIEW="DE-SELECT"
- IF $DATA(@SCPTSEL@(SCNT))
- QUIT
- +16 ;
- +17 SET VALMCNT=VALMCNT+1
- +18 SET Y=@SCPTALL@(SCNT,0)
- +19 SET @VALMAR@(VALMCNT,0)=$$SETSTR^VALM1(VALMCNT,Y,1,4)
- +20 ;
- +21 ; -- set idx to pointer back to SCPTALL (this is key!)
- +22 SET @VALMAR@("IDX",VALMCNT,VALMCNT)=SCNT
- +23 QUIT
- End DoDot:2
- +24 QUIT
- End DoDot:1
- +25 ;
- +26 IF '$ORDER(@VALMAR@(0))
- Begin DoDot:1
- +27 SET @VALMAR@(1,0)=" "
- +28 SET @VALMAR@(2,0)=" "
- +29 SET @VALMAR@(3,0)=" No patients to list."
- +30 QUIT
- End DoDot:1
- +31 IF $GET(VALMBG)
- IF '$DATA(@VALMAR@(VALMBG,0))
- SET VALMBG=1
- +32 KILL VALMHDR
- +33 DO BACK("R")
- +34 QUIT
- +35 ;
- SETSEL(FLAG,SCNT) ; -- set selected flag indicator
- +1 NEW Y,SCPTCNT
- +2 ;
- +3 ; -- get pointer back to SCPTALL
- +4 SET SCPTCNT=+$GET(@VALMAR@("IDX",SCNT,SCNT))
- +5 IF FLAG="DE-SELECT"
- IF $DATA(@SCPTSEL@(SCPTCNT))
- Begin DoDot:1
- +6 KILL @SCPTSEL@(SCPTCNT)
- +7 SET SCSELCNT=$SELECT(SCSELCNT=0:0,1:SCSELCNT-1)
- End DoDot:1
- +8 ;
- +9 IF FLAG="SELECT"
- IF '$DATA(@SCPTSEL@(SCPTCNT))
- Begin DoDot:1
- +10 SET @SCPTSEL@(SCPTCNT)=""
- +11 SET SCSELCNT=$SELECT(SCSELCNT=SCALLCNT:SCALLCNT,1:SCSELCNT+1)
- End DoDot:1
- +12 ;
- +13 SET Y=$GET(@VALMAR@(SCNT,0))
- +14 SET Y=$$SETSTR^VALM1($SELECT(FLAG="SELECT":"Yes",1:""),Y,8,3)
- +15 SET @VALMAR@(SCNT,0)=Y
- +16 ;
- +17 ; -- need to do SCPTALL separately because of potential for differnt #'s
- +18 SET Y=$GET(@SCPTALL@(SCPTCNT,0))
- +19 SET Y=$$SETSTR^VALM1($SELECT(FLAG="SELECT":"Yes",1:""),Y,8,3)
- +20 SET @SCPTALL@(SCPTCNT,0)=Y
- +21 QUIT
- +22 ;
- HELP ; -- help code
- +1 SET X="?"
- DO DISP^XQORM1
- WRITE !!
- +2 QUIT
- +3 ;
- EXIT ; -- exit code
- +1 DO CLEAR^VALM1
- +2 KILL @VALMAR,SCSELCNT,SCVIEW,SCALLCNT,SCMSG
- +3 KILL @SCPTALL,@SCPTSEL,@SCPTINFO
- +4 KILL SCPTALL,SCPTSEL,SCPTINFO
- +5 QUIT
- +6 ;
- EXPND ; -- expand code
- +1 QUIT
- +2 ;
- ALL(SCACT) ; -- entry point for SCMC SELECT ALL & SCMC DESELECT ALL protocols
- +1 IF SCVIEW=SCACT
- Begin DoDot:1
- +2 WRITE !!,"All patients in current view are already '"_SCACT_"ED'."
- +3 DO PAUSE
- +4 DO BACK("")
- +5 QUIT
- End DoDot:1
- QUIT
- +6 DO ACT(SCACT,SCPTALL)
- +7 QUIT
- +8 ;
- SOME(SCACT) ; -- entry point for SCMC SELECT SOME & SCMC DESELECT SOME protocols
- +1 IF SCVIEW=SCACT
- Begin DoDot:1
- +2 WRITE !!,"All patients in current view are already '"_SCACT_"ED'."
- +3 DO PAUSE
- +4 DO BACK("")
- +5 QUIT
- End DoDot:1
- QUIT
- +6 DO EN^VALM2(XQORNOD(0),"O")
- +7 DO ACT(SCACT,"VALMY")
- +8 QUIT
- +9 ;
- ACT(SCACT,SCLIST) ; -- change select flag
- +1 NEW SCNT
- +2 SET SCNT=0
- +3 FOR
- SET SCNT=$ORDER(@SCLIST@(SCNT))
- if 'SCNT
- QUIT
- DO SETSEL(SCACT,SCNT)
- +4 WRITE !
- +5 DO WAIT^DICD
- DO BLD
- +6 QUIT
- +7 ;
- VIEW(SCVW) ; -- change view
- +1 SET SCVIEW=SCVW
- +2 WRITE !
- +3 DO WAIT^DICD
- DO BLD
- +4 QUIT
- +5 ;
- BACK(ACTION) ; -- return to lm processing
- +1 IF $GET(SCMSG)
- DO MSG
- +2 SET VALMBCK=ACTION
- +3 QUIT
- +4 ;
- MSG ; -- set message var
- +1 SET VALMSG="* Future date"
- +2 QUIT
- +3 ;
- DATE(SCDATE,SCDTE) ; -- setup date array
- +1 SET SCDTE="SCDTE"
- +2 SET SCDTE("BEGIN")=SCDATE
- +3 SET SCDTE("END")=9999999
- +4 SET SCDTE("INCL")=0
- +5 QUIT
- +6 ;
- PAUSE ; -- pause
- +1 NEW DIR,Y
- +2 SET DIR(0)="EA"
- +3 SET DIR("A")="Enter RETURN to continue:"
- +4 DO ^DIR
- +5 QUIT